|
|
没有问题，不过这样一来第一、二列要求写工作簿、工作表名就没有意义了，下面代码已经把这个功能注释化了，如果你需要去掉撇号就可以了：
Sub Macro1()
Dim arrpath$(), arr, brr(), sh As Worksheet, i&, j&, m&, n&, k&, d As Object, ds As Object
Dim myPath$, myFile$, wb As Workbook, s$, w$
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
' d("工作簿") = 1
' d("工作表") = 2
' m = 2
Set wb1 = ThisWorkbook
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path & "\数据源\"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
n = n + 1 '工作簿计数
ReDim Preserve arrpath(1 To n) '重新定义工作簿路径数组
arrpath(n) = myPath & myFile '记录工作簿路径
Set wb = GetObject(arrpath(n)) '调用这个工作簿
For Each sh In wb.Sheets
With sh
If IsSheetEmpty = IsEmpty(.UsedRange) Then
arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
For j = 1 To UBound(arr, 2)
If Not d.Exists(arr(1, j)) Then
m = m + 1
d(arr(1, j)) = m
End If
Next
End If
End With
Next
wb.Close False
myFile = Dir
Loop
ReDim brr(1 To 60000, 1 To d.Count)
m = 0
For k = 1 To n '逐个工作簿
' w = Split(Split(arrpath(k), "\")(UBound(Split(arrpath(k), "\"))), ".")(0)
Set wb = GetObject(arrpath(k)) '调用工作簿
For Each sh In wb.Sheets
With sh
If IsSheetEmpty = IsEmpty(.UsedRange) Then
' s = .Name
arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
For i = 2 To UBound(arr)
If Not ds.Exists(arr(i, 2)) Then
m = m + 1
ds(arr(i, 2)) = m
' brr(m, 1) = w
' brr(m, 2) = s
For j = 1 To UBound(arr, 2)
brr(m, d(arr(1, j))) = arr(i, j)
Next
Else
For j = 3 To UBound(arr, 2)
brr(ds(arr(i, 2)), d(arr(1, j))) = brr(ds(arr(i, 2)), d(arr(1, j))) + arr(i, j)
Next
End If
Next
End If
End With
Next
wb.Close False
Next
ActiveSheet.UsedRange.ClearContents
[a1].Resize(, d.Count) = d.Keys
[a2].Resize(m, d.Count) = brr
Application.ScreenUpdating = True
MsgBox "汇总完毕"
End Sub
多工作簿，同格式不同标题汇总.rar
(37.56 KB, 下载次数: 235)
|
|
楼主: 商人
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-6-26 20:04
楼主
