| |
▼高校新人教師 さん：
▼高校新人教師 さん：
>（データ整形で、数学と英語の平均点は、第５フィールド、第６フィールドでそろっていますので、コメント内の,によってフィールドがずれてしまう問題にはお手数でしたら、対応しなくても大丈夫です。）
このコードでは、先頭フィールドを0としている為、「数学と英語の平均点は、第4フィールド、第5フィールド」と成ります
Option Explicit
Public Sub DataExtract_高校新人教師()
' ★1、抽出件数表示の為の変数追加 2010-12-18
' ★2、抽出Keyの記入忘れ対策方法変更の為、vntMarkの確認を削除 2011-1-4
' ★3、CSVReadプロシージャの引数追加の対応の為 2010-12-18
' ★4、抽出件数表示の為に変更 2010-12-18
' ★5、抽出Keyの記入忘れ対策の為、vntMarkの確認を追加 2011-1-4
Dim i As Long
Dim vntInFiles As Variant
Dim dfo As Integer
Dim vntOutput As Variant
Dim strPath As String
Dim vntMark As Variant
Dim strProm As String
Dim lngCount As Long '★1追加
Dim vntTmp As Variant '★5追加
'指定形式のファイル名を取得
strPath = ThisWorkbook.Path & "\"
If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'出力ファイル名を取得
If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'抽出する下限、上限値を取得
' With Worksheets("Sheet1") '★2削除
' vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value '★2削除
' If VarType(vntMark) <> vbArray + vbVariant Then '★2削除
' strProm = "探索Keyが設定されていません" '★2削除
' GoTo Wayout '★2削除
' End If '★2削除
' End With '★2削除
vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2) '★5追加
For Each vntTmp In vntMark '★5追加
If IsEmpty(vntTmp) Then '★5追加
strProm = "探索Keyが設定されていません" '★5追加
GoTo Wayout '★5追加
End If '★5追加
Next vntTmp '★5追加
'出力ファイルをOpen
dfo = FreeFile
Open vntOutput For Output As dfo
For i = 1 To UBound(vntInFiles)
'データの読み込み
CSVRead vntInFiles(i), dfo, vntMark, lngCount '★3引数追加
Next i
Close dfo
strProm = lngCount & "件の抽出処理が完了しました" '★4変更
Wayout:
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
dfo As Integer, _
vntMark As Variant, _
lngCount As Long, _
Optional strDelim As String = ",")
' ★1、引数にlngCountを追加 2010-12-18
' ★2、SplitCsvの行が抜けているので追加 2010-12-18
' ★3、フィールド数が一定に成った為、削除 2011-1-4
' ★4、上記理由により変更 2011-1-4
' (数学が4番目のフィールド、英語が5番目のフィールド)
' ★5、抽出行数をカウントするコードを追加 2011-1-4
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
Dim i As Long
' Dim lngMax As Long '★3削除
'ファイルをOpen
dfn = FreeFile
Open strFileName For Input As dfn
Do Until EOF(dfn)
'１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'論理レコードをフィールドに分割
vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
'フィールド内で改行が無い場合
If Not blnMulti Then
If vntField(0) <> "" Then
'★3、前回「自由コメント」に「,」が有る為、フィールド数が不定により
'最終列を求め、後ろから何列目としたため必要としたので不必要
' lngMax = UBound(vntField) '★3削除
'数学の上下限で且つ英語の上下限に入るなら
'★4、当然以下の行も変更
' If vntMark(1, 1) <= Val(vntField(lngMax - 1)) _
' And Val(vntField(lngMax - 1)) <= vntMark(1, 2) Then
' If vntMark(2, 1) <= Val(vntField(lngMax)) _
' And Val(vntField(lngMax)) <= vntMark(2, 2) Then
'数学の平均点（4番目のフィールド）が指定値以上なら
If vntMark(1, 1) <= Val(vntField(4)) _
And Val(vntField(4)) <= vntMark(1, 2) Then
'英語の平均点（5番目のフィールド）が指定値以上なら
If vntMark(2, 1) <= Val(vntField(5)) _
And Val(vntField(5)) <= vntMark(2, 2) Then
Print #dfo, strRec
lngCount = lngCount + 1 '★5追加
End If
End If
End If
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbCrLf
End If
Loop
Close #dfn
End Sub
|
|
高校新人教師
- 11/1/5(水) 19:34 -
