|
|
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim ar(), br(), arr()
With Me.ListBox1
ReDim ar(1 To .ListCount)
ReDim br(1 To .ListCount)
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
If InStr(.List(i, 0), "xls") > 0 Then
m = m + 1
br(m) = i
End If
End If
Next i
m = m + 1
br(m) = .ListCount - 1
If m = 1 Then MsgBox "请选择要汇总的工作簿和相应的工作表": Exit Sub
ReDim arr(1 To 100000, 1 To 18)
For i = 1 To m - 1
ks = br(i) + 1
js = br(i + 1) - 1
wj = .List(br(i), 0)
f = Dir(ThisWorkbook.Path & "\合并\" & wj)
If f <> "" Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\合并\" & wj)
For s = ks To js
If .Selected(s) = True Then
gzb = .List(s, 0)
Set sh = wb.Worksheets(gzb)
With sh
mr = .[a1].CurrentRegion
End With
For ii = 3 To UBound(mr)
If mr(ii, 2) <> "" Then
n = n + 1
arr(n, 1) = n
For j = 1 To UBound(mr, 2)
arr(n, j + 1) = mr(ii, j)
Next j
arr(n, 3) = "" & arr(n, 3)
arr(n, 18) = ThisWorkbook.Path & "\合并\" & wj
End If
Next ii
End If
Next s
wb.Close False
End If
Next i
End With
With Sheets(1)
.[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(2) = Empty
.[a4].Resize(n, UBound(arr, 2)) = arr
.[a3].Resize(n + 1, UBound(arr, 2)).Borders.LineStyle = 1
For j = 5 To 17
If j <> 12 And j <> 13 Then
.Cells(3, j) = Application.Sum(.Range(.Cells(4, j), .Cells(n + 3, j)))
End If
Next j
.[d3] = "合计"
End With
Application.ScreenUpdating = True
MsgBox "合并完毕！"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-9-8 08:47
楼主