|
Sub 多薄多表合并为一薄多表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br(), arr()
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
ReDim br(1 To 50000, 1 To 4)
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(lj & f, 0)
For Each sh In wb.Worksheets
r = sh.Cells(Rows.Count, 12).End(xlUp).Row
ar = sh.Range("k2:n" & r)
For i = 2 To UBound(ar)
If ar(i, 1) = "是" Then
If ar(i, 2) <> "" Then
m = m + 1
For j = 2 To 4
br(m, j - 1) = ar(i, j)
Next j
br(m, 4) = Split(wb.Name, ".")(0)
End If
End If
Next i
Next sh
wb.Close False
End If
f = Dir
Loop
If m = "" Then MsgBox "没有需要汇总的数据!": End
For Each sh In Sheets
sh.UsedRange.Offset(1) = Empty
sh.UsedRange.Offset(1).Borders.LineStyle = 0
zd = Replace(sh.Name, "汇总表", "")
n = 0
ReDim arr(1 To m, 1 To 5)
For i = 1 To m
If br(i, 1) = zd Then
n = n + 1
arr(n, 1) = n
For j = 1 To 4
arr(n, j + 1) = br(i, j)
Next j
End If
Next i
If n > 0 Then
sh.[a2].Resize(n, UBound(arr, 2)) = arr
sh.[a2].Resize(n, UBound(arr, 2)).Borders.LineStyle = 1
End If
Next sh
Application.ScreenUpdating = True
MsgBox "汇总完毕!"
End Sub
|
|