Sub 汇总委托单数据()
Dim wsTemplate As Worksheet
Dim wsSummary As Worksheet
Dim wbSummary As Workbook
Dim dictHeaders As Object
Dim arrHeaders()
Dim lastRow As Long
Dim folderPath As String
Dim filePattern As String
Dim templateFile As String
Dim fileName As String
Dim cell As Range
Dim headerIndex As Integer
Dim i As Integer, j As Integer
' 初始化设置
Set dictHeaders = CreateObject("Scripting.Dictionary")
templateFile = "InfoTable.xlsx" ' 模板文件名
filePattern = "*.xlsx" ' 文件筛选模式
folderPath = ThisWorkbook.Path & "\" ' 假设代码运行在目标文件夹中
' 步骤1:解析模板文件获取标题
Application.ScreenUpdating = False
Workbooks.Open folderPath & templateFile
Set wsTemplate = Workbooks(templateFile).Sheets("委托单")
' 遍历模板B7:I16区域建立标题字典
headerIndex = 0
For Each cell In wsTemplate.Range("B7:I16")
If cell.Value = "" Then
' 跳过空列(即左侧单元格也为空的情况)
If cell.Offset(0, -1).Value <> "" Then
If Not dictHeaders.Exists(cell.Offset(0, -1).Value) Then
dictHeaders.Add cell.Offset(0, -1).Value, headerIndex
ReDim Preserve arrHeaders(headerIndex)
arrHeaders(headerIndex) = cell.Offset(0, -1).Value
headerIndex = headerIndex + 1
End If
End If
End If
Next cell
' 步骤2:创建汇总工作簿
Set wbSummary = Workbooks.Add
Set wsSummary = wbSummary.Sheets(1)
wsSummary.Name = "汇总数据"
' 写入标题行
For i = 0 To UBound(arrHeaders)
wsSummary.Cells(1, i + 1).Value = arrHeaders(i)
Next i
' 步骤3:遍历文件夹处理数据文件
fileName = Dir(folderPath & filePattern)
lastRow = 1
Do While fileName <> ""
If fileName <> templateFile And fileName <> wbSummary.Name Then
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(folderPath & fileName)
Dim wsSource As Worksheet
Set wsSource = wbSource.Sheets("委托单")
lastRow = lastRow + 1
Dim dataIndex As Integer
' 遍历模板标记的空单元格位置提取数据
For Each cell In wsTemplate.Range("B7:I16")
If cell.Value = "" Then
'