|
- Sub 汇总()
- Dim vData As Variant, nRow As Double, nCol As Integer
- Dim vFill As Variant, nFill As Double
- Dim dicSheet As Object
- Dim sFile As String, wWB As Workbook, wSH As Worksheet
-
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set dicSheet = CreateObject("Scripting.Dictionary")
- sFile = "开始查找"
- Do While sFile <> ""
- If sFile = "开始查找" Then
- sFile = Dir(ThisWorkbook.Path & "\*.xls*")
- Else
- If sFile <> ThisWorkbook.Name Then
- With Workbooks.Open(ThisWorkbook.Path & "" & sFile)
- For Each wSH In .Sheets
- If dicSheet.Exists(wSH.Name) Then
- vFill = dicSheet(wSH.Name)
- nFill = UBound(vFill, 2)
- Else
- vFill = Empty
- ReDim vFill(1 To 2, 1 To 1)
- nFill = 1
- vFill(1, 1) = "单位名称"
- vFill(2, 1) = "姓名"
- End If
- vData = wSH.[A1].CurrentRegion.Value
- For nRow = 2 To UBound(vData)
- nFill = nFill + 1
- ReDim Preserve vFill(1 To 2, 1 To nFill)
- For nCol = 1 To 2
- vFill(nCol, nFill) = vData(nRow, nCol)
- Next
- Next
- dicSheet(wSH.Name) = vFill
- Next
- .Close False
- End With
- End If
- sFile = Dir
- End If
- Loop
- ThisWorkbook.Activate
- For Each wSH In Sheets
- If wSH.Name <> "合并操作表" Then wSH.Delete
- Next
- If dicSheet.Count > 0 Then
- vData = Empty
- For Each vData In dicSheet.Keys
- Sheets.Add after:=Sheets(Sheets.Count)
- With ActiveSheet
- .Name = vData
- vFill = dicSheet(.Name)
- .[A1:B1].Resize(UBound(vFill, 2)) = Application.WorksheetFunction.Transpose(vFill)
- End With
- Next
- End If
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|