|
- Dim arr(), s&
- Sub Macro1()
- s = 0
- ReDim arr(1 To 20000, 1 To 7)
- zdir ThisWorkbook.Path & ""
- Range("a2").Resize(s, 7) = arr
- End Sub
- Sub zdir(p)
- Dim fs As Object, wb As Workbook
- Set fs = CreateObject("scripting.filesystemobject")
- Application.ScreenUpdating = False
- For Each f In fs.GetFolder(p).Files
- x = Split(f, "")
- If x(UBound(x)) <> ThisWorkbook.Name Then
- zf1 = x(UBound(x) - 1)
- zf2 = Replace(x(UBound(x)), ".xls", "")
- Set wb = GetObject(f)
- For i = 1 To wb.Sheets.Count
- zf3 = wb.Sheets(i).Name
- brr = wb.Sheets(i).[a1:s9]
- With CreateObject("vbscript.regexp")
- .Pattern = "\D"
- .Global = True
- d = .Replace(brr(2, 1), "")
- End With
- For j = 5 To 9
- If Not brr(j, 1) Like "*以下空白*" And brr(j, 1) <> "" And Not brr(j, 1) Like "*款付清*" Then
- s = s + 1
- arr(s, 1) = zf1
- arr(s, 2) = zf2
- arr(s, 3) = zf3
- arr(s, 4) = DateSerial(Left(d, 4), Mid(d, 5, 2), Right(d, 2))
- arr(s, 5) = brr(j, 1)
- arr(s, 6) = Replace(Join(Application.Index(brr, j, 0), ""), brr(j, 1), "") / 100
- End If
- If brr(j, 1) Like "*款付清*" Then arr(s, 7) = "款付清"
- Next
- Next
- wb.Close 0
- End If
- Next
- For Each m In fs.GetFolder(p).SubFolders
- zdir m
- Next
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|