| |
配列変数を使った逐次探索で行うか？、配列変数の代わりにDictionaryを使った探索を
行えば出来ると思います
逐次探索より、Dictionaryの方が速そうなので此方でDataExtract_Count1を書きます
Option Explicit
Public Sub DataExtract_Count1()
' Dictionaryを使用
Dim i As Long
Dim vntInFiles As Variant
Dim dfo As Integer
Dim vntOutput As Variant
Dim strPath As String
Dim vntKeys As Variant
Dim dicIndex As Object
Dim strProm As String
'指定形式のファイル名を取得
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
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(vntInFiles)
'データの読み込み
CSVRead vntInFiles(i), dicIndex
Next i
'出力ファイルをOpen
dfo = FreeFile
Open vntOutput For Output As dfo
With dicIndex
'Dictionaryに登録して有る全てのKeyを取得
vntKeys = .Keys
'全てのKeyに就いて繰り返し
For i = 0 To UBound(vntKeys)
'出力ファイルに書き出し
Print #dfo, vntKeys(i); ","; .Item(vntKeys(i))
Next i
End With
Close dfo
strProm = (UBound(vntKeys) + 1) & "件の抽出処理が完了しました"
Wayout:
Set dicIndex = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
dicIndex As Object, _
Optional strDelim As String = ",")
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
'ファイルを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
With dicIndex
'DictionaryにKeyとカウントを登録
.Item(vntField(0)) = .Item(vntField(0)) + 1
End With
End If
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbCrLf
End If
Loop
Close #dfn
End Sub
ただ、Dictionaryが大抵は使えると思いますが？、使えない環境も有りますので
其の場合は逐次探索で行います
Option Explicit
Public Sub DataExtract_Count2()
' 配列を逐次探索
Dim i As Long
Dim vntInFiles As Variant
Dim dfo As Integer
Dim vntOutput As Variant
Dim strPath As String
Dim vntKeys() As Variant
Dim lngMax As Long
Dim strProm As String
'指定形式のファイル名を取得
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
For i = 1 To UBound(vntInFiles)
'データの読み込み
CSVRead vntInFiles(i), vntKeys, lngMax
Next i
'出力ファイルをOpen
dfo = FreeFile
Open vntOutput For Output As dfo
'配列に登録して有る全てのKeyに就いて繰り返し
For i = 1 To lngMax
'出力ファイルに書き出し
Print #dfo, vntKeys(1, i); ","; vntKeys(2, i)
Next i
Close dfo
strProm = lngMax & "件の抽出処理が完了しました"
Wayout:
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
vntKeys() As Variant, _
lngMax As Long, _
Optional strDelim As String = ",")
Dim i As Long
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
'ファイルを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(0)の値が有るかを確認
For i = 1 To lngMax
If vntKeys(1, i) = vntField(0) Then
Exit For
End If
Next i
'無い場合
If i > lngMax Then
'配列を拡張
lngMax = lngMax + 1
ReDim Preserve vntKeys(1 To 2, 1 To lngMax)
'Keyとカウントを登録
vntKeys(1, lngMax) = vntField(0)
vntKeys(2, lngMax) = 1
Else
'カウントを更新
vntKeys(2, i) = vntKeys(2, i) + 1
End If
End If
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbCrLf
End If
Loop
Close #dfn
End Sub
|
|
Hirofumi
- 11/1/7(金) 8:00 -
