|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim mypath$, myname$
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- With Worksheets("汇总")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a4:a" & r)
- For i = 1 To UBound(arr)
- d(arr(i, 1)) = i
- Next
- End With
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*.xls")
- Do While myname <> ""
- If myname <> ThisWorkbook.Name Then
- ReDim brr(1 To d.Count, 1 To 4)
- wjm = Split(myname, ".")(0)
- Set wb = GetObject(mypath & myname)
- With wb
- With .Worksheets(1)
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("d2:k" & r)
- For i = 1 To UBound(arr)
- xm = Trim(arr(i, 1))
- If d.exists(xm) Then
- m = d(xm)
- For j = 1 To 4
- brr(m, j) = arr(i, j + 4)
- Next
- End If
- Next
- End With
- .Close False
- End With
- d1(wjm) = brr
- End If
- myname = Dir()
- Loop
- With Worksheets("汇总")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- .Range("b2").Resize(r - 1, .Columns.Count - 1).Clear
- n = 2
- For Each aa In d1.keys
- brr = d1(aa)
- With .Cells(2, n)
- .Value = aa
- .Resize(1, 4).Merge
- End With
- .Cells(3, n).Resize(1, 4) = Array("本期发" & vbLf & "生借方", "本期发" & vbLf & "生贷方", "期末余" & vbLf & "额借方", "期末余" & vbLf & "额贷方")
- .Cells(4, n).Resize(UBound(brr), 4) = brr
- n = n + 4
- Next
- n = n - 1
- .Range("a2").Resize(r - 1, n).Borders.LineStyle = xlContinuous
- .Range("b4").Resize(r - 3, n - 1).NumberFormatLocal = "0.00"
- .Range("a2").Resize(1, n).EntireColumn.AutoFit
- With .Range("a1").Resize(3, n)
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|