| |
▼つよぽん さん：
>下記マクロを実行するととんでもなく時間がかかり悩んでいます
>始めは快調に進むのですが最後は張り付いたように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) '１行めがタイトル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
|
|
Ｙｕｋｉ
- 10/1/2(土) 10:46 -
