|
- Sub 动态字段多薄多表合并为一表()
- Dim d, ar, br, sh As Worksheet, cr()
- Set d = CreateObject("Scripting.Dictionary")
- ThisWorkbook.Sheets.Add
- ActiveSheet.Name = "合并结果"
- bth = Val(Application.InputBox("请输入 需要的字段名所在的行号:", "默认值", "1"))
- Application.ScreenUpdating = False
-
- p = ThisWorkbook.Path & ""
- f = Dir(p & "*.xls*")
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- With Workbooks.Open(p & f)
- For Each sh In Sheets
- qsl = sh.UsedRange.Column
- zdl = sh.UsedRange.Columns.Count + sh.UsedRange.Column - 1
- qsh = bth
- zdh = sh.Cells(65536, qsl).End(xlUp).Row
- If sh.Name <> "合并结果" Then
- If zdh > 1 Then
- ar = sh.Cells(qsh, qsl).Resize(zdh - qsh + 1, zdl)
-
- For i = 1 To UBound(ar, 2)
-
- d(ar(1, i)) = 0
-
- Next
- End If
- End If
- Next
- .Close 0
- End With
- End If
- f = Dir
- Loop
- ReDim br(1 To 60000, 1 To d.Count): m = 1
- For i = 1 To d.Count
- d(d.keys()(i - 1)) = i
- br(1, i) = d.keys()(i - 1)
- Next
-
- p = ThisWorkbook.Path & ""
- f = Dir(p & "*.xls*")
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- With Workbooks.Open(p & f)
-
- For Each sh In Sheets
- qsl = sh.UsedRange.Column
- zdl = sh.UsedRange.Columns.Count + sh.UsedRange.Column - 1
- qsh = bth
- zdh = sh.Cells(65536, qsl).End(xlUp).Row
- If sh.Name <> "合并结果" Then
- If zdh > 1 Then
- ar = sh.Cells(qsh, qsl).Resize(zdh - qsh + 1, zdl)
-
- For i = 2 To UBound(ar)
- m = m + 1
- For j = 1 To UBound(ar, 2)
-
- br(m, d(ar(1, j))) = ar(i, j)
- ReDim Preserve cr(1 To m)
- If m = 2 Then
- cr(1) = "数据来源"
- End If
- cr(m) = f & "_" & sh.Name
- Next j
- Next i
- End If
- End If
- Next
-
- .Close 0
- End With
- End If
- f = Dir
- Loop
-
- With ActiveSheet
- .UsedRange.ClearContents
- .[a1].Resize(m, UBound(br, 2)) = br
- .[a1].Offset(0, UBound(br, 2) - 1).Resize(m, 1) = Application.Transpose(cr)
- End With
- LastRow = ActiveSheet.UsedRange.Rows.Count
- LastRow = LastRow + ActiveSheet.UsedRange.Row - 1
- For r = LastRow To 1 Step -1
- If WorksheetFunction.CountA(Rows(r)) = 0 Then Rows(r).Delete
- Next r
- LastColumn = ActiveSheet.UsedRange.Columns.Count
- LastColumn = LastColumn + ActiveSheet.UsedRange.Column
- For c = LastColumn To 1 Step -1
- If WorksheetFunction.CountA(Columns(c)) = 0 Then Columns(c).Delete
- Next c
- Application.ScreenUpdating = True
- MsgBox "合并完成!"
- End Sub
复制代码 通用型 动态字段合并 多薄多表 |
评分
-
2
查看全部评分
-
|