Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18248 / 76732 ←次へ | 前へ→

【63927】Re:マクロを早く快適に動かしたいです
回答  Hirofumi  - 09/12/31(木) 18:03 -

引用なし
パスワード
   ゴメン、なんかとちくるって、集計が上手く行かない?
多分、これで善いと思います

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
1 hits

【63908】マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 6:33 質問
【63910】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 10:40 発言
【63914】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 14:09 発言
【63916】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 15:13 発言
【63917】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 15:19 発言
【63918】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:31 回答
【63919】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:36 回答
【63921】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 17:12 回答
【63927】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 18:03 回答
【63928】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:10 発言
【63932】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 19:07 発言
【63933】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 19:40 発言
【63935】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 20:33 発言
【63936】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:01 発言
【63939】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:32 質問
【63940】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 18:39 発言
【63942】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 19:16 お礼
【63948】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 22:23 発言
【63949】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:21 発言
【63950】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:29 発言
【63920】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 17:08 発言
【63924】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 17:48 発言
【63925】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 17:53 発言
【63929】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:41 発言
【63931】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:50 発言
【63937】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:04 発言
【63934】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 20:14 発言
【63938】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 22:54 発言
【63941】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:57 発言
【63943】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 19:41 発言
【63930】Re:マクロを早く快適に動かしたいです よろずや 09/12/31(木) 18:44 発言
【63944】Re:マクロを早く快適に動かしたいです Yuki 10/1/2(土) 10:46 発言
【63945】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/2(土) 11:11 発言

18248 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free