Excel VBA質問箱 IV

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

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


18256 / 76732 ←次へ | 前へ→

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

引用なし
パスワード
   ごめん、一部間違えていました

Option Explicit
Option Compare Text

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\月間データ統合"
  '※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(lngIndex(i), 1) & "," _
                  & vntField(lngIndex(i), 2) & "," _
                  & vntField(lngIndex(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
0 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 発言

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