Excel VBA質問箱 IV

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

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


18231 / 76732 ←次へ | 前へ→

【63944】Re:マクロを早く快適に動かしたいです
発言  Yuki  - 10/1/2(土) 10:46 -

引用なし
パスワード
   ▼つよぽん さん:
>下記マクロを実行するととんでもなく時間がかかり悩んでいます
>始めは快調に進むのですが最後は張り付いたように15時間ほどかかります
>なんとか早くするにはどうしたらよいものでしょうか?
>行いたいのはフォルダ内にあるそれぞれのフォルダのデータを統合したいのです。
>小さいデータなら問題なく動くのですが…よろしくお願いします

もう、解決されていられるようですが
遅らせながら、サンプルです。そこそこ早いです。


Public Sub TestFileConvert()
  Dim v1   As Variant
  Dim v2   As Variant
  Dim v3()  As String
  Dim buf()  As Byte
  Dim strDir As String
  Dim sF()  As String
  Dim i    As Long
  Dim j    As Long
  Dim strYm  As String
  Dim IO   As Integer
  Dim Dic   As Object
  Dim strKy  As Variant
  Dim strKy1 As String
  Dim sK   As String
  Dim flg   As Boolean
  Dim tt
  
  tt = Timer
 
  strYm = "200912"    ' 処理月
  strDir = "C:\Documents and Settings\月間データ統合\"    'データフォルダ最後に\

  sF = GetFiles(strDir, strYm)
  If Sgn(sF) = 0 Then Exit Sub
  ' 縦横逆用
  ShelSortStrA sF(), UBound(sF, 2) + 1, 1
  
  Set Dic = CreateObject("Scripting.Dictionary")
  ReDim Preserve sF(1, UBound(sF, 2) + 1)
  For i = LBound(sF, 2) To UBound(sF, 2) + 1
    If i = UBound(sF, 2) Then flg = True
    If sK = "" Then
      sK = sF(0, i)
    Else
      If sK <> sF(0, i) Then
        v1 = Dic.Keys
        v2 = Dic.Items
        Dic.RemoveAll
        ReDim v3(1, UBound(v1))
        For j = 0 To UBound(v1)
          v3(0, j) = v1(j)
          v3(1, j) = v2(j)
        Next
        ShelSortStrA v3(), UBound(v3, 2) + 1, 1
        IO = FreeFile
        Open strDir & sK For Output As #IO
          Print #IO, "商品CD, 数量"
          For j = 0 To UBound(v3, 2)
            Print #IO, v3(0, j) & "," & v3(1, j)
          Next
        Close #IO
        sK = sF(0, i)
      End If
      If flg Then Exit For
    End If
    DoEvents
    IO = FreeFile
    Open sF(1, i) & sF(0, i) For Binary Lock Read As #IO
      ReDim buf(LOF(IO) - 3)
      Get #IO, , buf
    Close #IO
    v1 = Split(StrConv(buf, vbUnicode), vbCrLf)
    For j = 0 To UBound(v1)                          '1行めがタイトルaの時は 1 から
      v2 = Split(v1(j), ",")
      Dic(v2(1)) = Dic(v2(1)) + CLng(v2(2))
    Next
  Next
  Debug.Print Timer - tt
End Sub

Private Function GetFiles(ByVal Path As String, YM As String) As String()
  Dim sDir  As String
  Dim sD()  As String
  Dim sFile  As String
  Dim sF()  As String
  Dim i    As Long
  Dim j    As Long
  Dim sDt   As String
  Dim eDt   As String
  
  sDt = YM & "01"
  eDt = Format(DateAdd("d", -1, DateAdd("m", 1, _
         CDate(Format(sDt, "0000/00/00")))), "yyyymmdd")
  sDir = Dir(Path, vbDirectory)
  Do While sDir <> ""
    If sDir <> "." And sDir <> ".." Then
      If (GetAttr(Path & sDir) And vbDirectory) = vbDirectory Then
        If sDir >= sDt And sDir <= eDt Then
          ReDim Preserve sD(i)
          sD(i) = Path & sDir & "\"
          i = i + 1
        End If
      End If
    End If
    sDir = Dir
  Loop
  
  For i = LBound(sD) To UBound(sD)
    sFile = Dir(sD(i) & "*.csv")
    Do While sFile <> ""
      ReDim Preserve sF(1, j)
      sF(0, j) = sFile
      sF(1, j) = sD(i)
      j = j + 1
      sFile = Dir()
    Loop
  Next
  GetFiles = sF()
End Function


'**************************** ShelSortStrA 引数 *********************
'  data() データ
'  Count  要素の数
'  Sort  1 = 昇順, -1 = 降順
'*********************************************************************
Public Sub ShelSortStrA(data() As String, Count As Long, Sort As Long)
  Dim ix   As Long
  Dim iy   As Long
  Dim iz   As Long
  Dim strTemp As String
  Dim temp1  As Variant
  Dim temp2  As Variant
  Dim gap   As Long
  
  gap = Count \ 2
  Do While gap > 0
    iz = 0
    Do While iz < gap
      iy = iz + gap
      Do While iy < Count
        ix = iy - gap
        Do While ix >= iz
          If StrComp(data(0, ix), data(0, ix + gap), 1) = Sort Then
            temp1 = data(0, ix + gap)
            temp2 = data(1, ix + gap)
            data(0, ix + gap) = data(0, ix)
            data(1, ix + gap) = data(1, ix)
            data(0, ix) = temp1
            data(1, ix) = temp2
          Else
            Exit Do
          End If
          ix = ix - gap
        Loop
        iy = iy + gap
      Loop
      iz = iz + 1
    Loop
    gap = gap \ 2
  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 発言

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