Public Sub GatherDataPicker()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"
Dim Dic As Object On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim OpenSht As Worksheet
Const SHEET_INDEX = 1
Const OFFSET_ROW As Long = 1 Dim FolderPath As String
Dim FileName As String
Dim FileCount As Long
Dim qIndex As String '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "请选取Excel工作簿所在文件夹"
If .Show = -1 Then
FolderPath = .SelectedItems(1)
Else
MsgBox "您没有选中任何文件夹，本次汇总中断！"
Exit Sub
End If
End With
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\" '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set wb = Application.ThisWorkbook '工作簿级别
Set Sht = wb.ActiveSheet
Sht.UsedRange.Offset(0, 2).ClearContents 'FolderPath = ThisWorkbook.Path & "\"
FileCount = 0
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
Set Dic = CreateObject("Scripting.Dictionary")
FileCount = FileCount + 1
Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
With OpenWb
Set OpenSht = OpenWb.Worksheets(1)
With OpenSht
endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Set Rng = .Range("a1").CurrentRegion
arr = Rng.Value
For j = LBound(arr, 2) + 1 To UBound(arr, 2)
For i = LBound(arr) + 1 To UBound(arr)
FileName = Split(FileName, ".")(0)
qIndex = Replace(arr(1, j), "Q", "")
Key = CStr(arr(i, j))
'Dim uk As String
uk = FileName & ";" & qIndex & ";" & Key
Dic(uk) = Dic(uk) + 1
'Debug.Print FileName, " "; qIndex
Next i
Next j
End With
.Close False
End With With Sht
endcol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column + 1
endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row .Cells(1, endcol).Value = FileName For i = 3 To endrow
If .Cells(i, 1).Value <> "" Then qIndex = .Cells(i, 1).Value
Key = .Cells(i, 2).Value Debug.Print i; " "; qIndex If Key <> "无效" Then
uk = FileName & ";" & qIndex & ";" & Key
.Cells(i, endcol).Value = Dic(uk)
Dic.Remove uk
Else
mysum = 0
uk = FileName & ";" & qIndex & ";"
For Each k In Dic.keys
If InStr(1, k, uk) > 0 Then mysum = mysum + Dic(k)
Next k
.Cells(i, endcol).Value = mysum
End If
Next i
End With End If
FileName = Dir
Loop
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
UsedTime = VBA.Timer - StartTime ErrorExit:
Set wb = Nothing
Set Sht = Nothing
Set OpenWb = Nothing
Set OpenSht = Nothing
Set Rng = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub