|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 数据汇总()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet")
r = .Cells(Rows.Count, 1).End(xlUp).Row
rs = .Cells(2, Columns.Count).End(xlToLeft).Column
.Range(.Cells(3, 1), .Cells(r + 1, rs)) = Empty
cr = .Range(.Cells(2, 1), .Cells(10000, rs))
For j = 2 To UBound(cr, 2)
If Trim(cr(1, j)) <> "" Then
zf = Trim(cr(1, j))
d(zf) = j
End If
Next j
n = 1
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
ws = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ar = wb.Worksheets(1).Range("a1:w" & ws)
wb.Close False
For i = 3 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
n = n + 1
cr(n, 1) = n - 1
For j = 1 To UBound(ar, 2)
If Trim(ar(3, j)) <> "" Then
lh = d(Trim(ar(3, j)))
If lh <> "" Then
cr(n, lh) = ar(i, j)
End If
End If
Next j
End If
Next i
End If
f = Dir
Loop
.[a2].Resize(n, UBound(cr, 2)) = cr
End With
Application.ScreenUpdating = False
MsgBox "数据合并完毕!", 64, "提示"
End Sub
|
|