| |
一番大きなミス？は、「Sub CSVRead」の中でSplitCsvの呼び出しを削除している事です
一見「Sub CSVRead」を使って無い様に見えるのですが、使ってますので消さないで下さい
後の変更は、各プロシージャの先頭に変更を書き込んで有ります
これで動かない様ならまた、その旨をUpして下さい
Option Explicit
Public Sub DataExtract_高校新人教師()
' ★1、抽出件数表示の為の変数追加 2010-12-18
' ★2、抽出Keyの記入忘れ対策の為、vntMarkの確認を追加 2010-12-18
' ★3、CSVReadプロシージャの引数追加の対応の為 2010-12-18
' ★4、抽出件数表示の為に変更 2010-12-18
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追加
'指定形式のファイル名を取得
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")
vntMark = .Range(.Cells(2, "E"), .Cells(Rows.Count, "E").End(xlUp).Offset(1)).Value
If VarType(vntMark) <> vbArray + vbVariant Then '★2追加
strProm = "探索Keyが設定されていません" '★2追加
GoTo Wayout '★2追加
End If '★2追加
End With
'出力ファイルを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
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
Dim i As Long
'ファイルを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
'配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
'・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
'レコード中に、例えば「鈴木」という名前がある行を抽出
For i = 1 To UBound(vntMark, 1) - 1
'名前若しくはコメントの中に指定した文字列在る場合
If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
'Forを抜ける
Exit For
End If
Next i
'もし指定文字列が有った場合
If i <= UBound(vntMark, 1) - 1 Then
'合成レコードを出力
Print #dfo, strRec
'出力行数をカウント
lngCount = lngCount + 1 '★2追加
End If
End If
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbCrLf
End If
Loop
Close #dfn
End Sub
|
|
Hirofumi
- 10/12/18(土) 9:59 -
