| |
Csvのサンプルが無いのと、結果のサンプルが無いのでテスト出来ませんが
概ねこんなかな？
Option Explicit
Sub 月間データ統合_2()
Dim dataFolder As String
Dim fileName As String
Dim r As Long
Dim i As Long
Dim vntFileNames() As Variant
Dim dfn As Integer
Dim strBuff As String
Dim vntField As Variant
Dim lngIndex() As Long
Dim vntKeys As Variant
Dim dicIndex As Object
' Application.ScreenUpdating = False
'データフォルダ
' dataFolder = "C:\Documents and Settings\月間データ統合"
dataFolder = ThisWorkbook.Path & "\BBB"
'※csvファイル名取得
FileList dataFolder, vntFileNames, Sheets("Sheet1")
'※bookへcsvファイルを集計
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'B列の行数回
For r = 1 To UBound(vntFileNames, 1) - 1
'次のB列の値が違っていたら（csvファイル名が違っていたら）
If vntFileNames(r, 1) <> vntFileNames(r + 1, 1) Then
With dicIndex
If .Count > 0 Then
'Dictionaryの全てのKeyを出力
vntKeys = dicIndex.Keys
'結果用配列を確保
ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 3), _
lngIndex(1 To UBound(vntKeys) + 1)
'結果を配列に出力
For i = 0 To UBound(vntKeys)
vntField(i + 1, 1) = vntKeys(i)
vntField(i + 1, 2) = vntField(i + 1, 1)
vntField(i + 1, 3) = .Item(vntKeys(i))
'Indexを作成
lngIndex(i + 1) = i + 1
Next i
'Dictionaryをクリア
.RemoveAll
'配列を2列目をKeyに整列
ShellSort vntField, lngIndex, 2
'出力ファイルをOpen
fileName = dataFolder & "\" & vntFileNames(r, 1) & ".csv"
dfn = FreeFile
Open fileName For Output As dfn
'ファイルに出力
For i = 1 To UBound(vntField, 1)
Print #dfn, vntField(i, 1) & "," & vntField(i, 2) & "," & vntField(i, 3)
Next i
'ファイルをClose
Close dfn
End If
End With
Else
'csvファイルのファイル名取得
fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
'csvファイルをOpen
dfn = FreeFile
Open fileName For Input As dfn
'ファイルエンドまで繰り返し
Do Until EOF(dfn)
'Csvからいレコード読み込み
Line Input #dfn, strBuff
'読み込んだレコードをフィールドに分割
vntField = SplitCsv(strBuff, ",")
With dicIndex
If .Exists(vntField(1)) Then
.Item(vntField(1)) = .Item(vntField(1)) + Val(vntField(2))
Else
.Add vntField(1), Val(vntField(2))
End If
End With
Loop
'csvファイルを閉じる
Close dfn
End If
Next r
Set dicIndex = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet)
Dim i As Long
Dim r As Long
Dim strName As String
Dim strSFolder() As String
Dim strFiles() As String
'※フォルダ名取得
'データフォルダ内のフォルダとファイルを取得
strName = Dir(strPath & "\", vbDirectory)
'なくなるまで
Do While strName <> ""
'ディレクトリで
If (GetAttr(strPath & "\" & strName) And vbDirectory) = vbDirectory Then
' 現在のフォルダと親フォルダでなければ
If strName <> "." And strName <> ".." Then
'配列にサブフォルダ名を列挙
r = r + 1
ReDim Preserve strSFolder(1 To r)
strSFolder(r) = strName
End If
End If
'次のフォルダ名を取得
strName = Dir
Loop
'※csvファイル名取得
r = 0
For i = 1 To UBound(strSFolder)
'フォルダ内の最初のcsvファイル名を取得
strName = Dir(strPath & "\" & strSFolder(i) & "\*.csv")
'csvファイルがある間
Do While strName <> ""
r = r + 1
ReDim Preserve strFiles(1 To 2, 1 To r)
'作業シートのB列にcsvファイル名の名前のみ取得
strFiles(1, r) = Left(strName, InStrRev(strName, ".") - 1)
'作業シートのC列にフォルダ名（日付）取得
strFiles(2, r) = strSFolder(i)
'次のcsvファイルを取得
strName = Dir
Loop
Next
With wksWork
'作業シートクリア
.Cells.Clear
'データ出力
.Range("B1").Resize(r, 2).Value = Application.WorksheetFunction.Transpose(strFiles)
'ファイル名、フォルダ名で並べ替え
.Range("B1").Resize(r, 2).Sort _
Key1:=.Range("B1"), Order1:=xlAscending, _
Key2:=.Range("C1"), Order2:=xlAscending, _
Header:=xlNo
'ファイル名を配列に取得
vntFileNames = .Range("B1").Resize(r + 1, 2).Value
End With
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As Variant
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = Empty
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Sub ShellSort(vntList As Variant, _
lngIndex() As Long, _
Optional lngKey As Long = 1)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim lngTmp As Variant
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(vntList, 1)
lngEnd = UBound(vntList, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap = 0
For i = lngGap + lngTop To lngEnd
lngTmp = lngIndex(i)
For j = i To lngGap + lngTop Step -lngGap
If vntList(lngIndex(j - lngGap), lngKey) _
<= vntList(lngTmp, lngKey) Then
Exit For
End If
lngIndex(j) = lngIndex(j - lngGap)
Next j
lngIndex(j) = lngTmp
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
Hirofumi
- 09/12/31(木) 15:31 -
