| |
ゴメン、なんかとちくるって、集計が上手く行かない？
多分、これで善いと思います
Option Explicit
Option Compare Text
Sub 月間データ統合_4()
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
Dim strPrompt As String
Application.ScreenUpdating = False
'データフォルダ
dataFolder = "C:\Documents and Settings\月間データ統合"
'※csvファイル名取得
If Not FileList(dataFolder, vntFileNames, Sheets("Sheet1")) Then
strPrompt = "ファイルが有りません"
GoTo Wayout
End If
'※bookへcsvファイルを集計
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'csvファイルのファイル名取得
fileName = dataFolder & "\" & vntFileNames(1, 2) & "\" & vntFileNames(1, 1) & ".csv"
'データ取得
GetData fileName, dicIndex
'B列の行数回-1
For r = 2 To UBound(vntFileNames, 1)
'次のB列の値が違っていたら（csvファイル名が違っていたら）
If vntFileNames(r - 1, 1) <> vntFileNames(r, 1) Then
With dicIndex
'Dictionaryの全てのKeyを出力
vntKeys = dicIndex.Keys
'結果用配列を確保
ReDim vntField(1 To UBound(vntKeys) + 1, 1 To 2), _
lngIndex(1 To UBound(vntKeys) + 1)
'結果を配列に出力
For i = 0 To UBound(vntKeys)
vntField(i + 1, 1) = vntKeys(i)
vntField(i + 1, 2) = .Item(vntKeys(i))
'Indexを作成
lngIndex(i + 1) = i + 1
Next i
'Dictionaryをクリア
.RemoveAll
'配列を2列目をKeyに整列
ShellSort vntField, lngIndex, 1
'出力ファイルを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(lngIndex(i), 1) & "," _
& vntField(lngIndex(i), 1) & "," _
& vntField(lngIndex(i), 2)
Next i
'ファイルをClose
Close dfn
End With
End If
If vntFileNames(r, 1) <> "" Then
'csvファイルのファイル名取得
fileName = dataFolder & "\" & vntFileNames(r, 2) & "\" & vntFileNames(r, 1) & ".csv"
'データ取得
GetData fileName, dicIndex
End If
Next r
strPrompt = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Application.ScreenUpdating = True
MsgBox strPrompt, vbInformation
End Sub
Private Sub GetData(strFile As String, dicIndex As Object)
Dim i As Long
Dim vntField As Variant
Dim dfn As Integer
Dim strBuff As String
'csvファイルをOpen
dfn = FreeFile
Open strFile 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 Sub
Private Function FileList(strPath As String, vntFileNames() As Variant, wksWork As Worksheet) As Boolean
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
If r < 1 Then
Exit Function
End If
'※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
If r < 1 Then
Exit Function
End If
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
FileList = True
End Function
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(木) 18:03 -
