汇总文件数据 VBA

1 读取30个文件的数据信息

2 根据4个key值，判断累计数据

3 做sum ， avg

Sub 月汇总()
 
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim num As Long
  
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "" & "*.xlsx")
AWbName = ActiveWorkbook.Name
ActiveWorkbook.Worksheets(1).Name = "BaseData"   '工作表命名，基础数据表
ActiveWorkbook.Worksheets(2).Name = "Summary"    '工作表命名，数据汇总以及计算表

Dim Data As Worksheet
Dim Summary As Worksheet
Set Data = ThisWorkbook.Sheets("BaseData")
Set Summary = ThisWorkbook.Sheets("Summary")
Data.Activate

Data.Columns(1).ColumnWidth = 13    '设置第 1 列宽度
Data.Columns(2).ColumnWidth = 23    '设置第 2 列宽度
Data.Columns(3).ColumnWidth = 13    '设置第 3 列宽度
Data.Columns(4).ColumnWidth = 13    '设置第 4 列宽度
Data.Columns(5).ColumnWidth = 13    '设置第 5 列宽度
Data.Columns(6).ColumnWidth = 13    '设置第 6 列宽度
Data.Columns(7).ColumnWidth = 13    '设置第 5 列宽度
Data.Columns(8).ColumnWidth = 13    '设置第 6 列宽度


Data.Cells.Clear  '清空工作表的内容和格式
Summary.Cells.Clear  '清空工作表的内容和格
Data.Rows.Interior.ColorIndex = 0   '清空所有背景色
Summary.Rows.Interior.ColorIndex = 0   '清空所有背景色
Data.Cells(Range("A65536").End(xlUp).Row, 2).HorizontalAlignment = 4 '右对齐

num = 0
Dim test As Long

'============================ step1: 准备基础数据，整合到一张工作薄中的一张工作表 ============================
Do While MyName <> ""
    If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "" & MyName)    '打开文件
        num = num + 1
        
        With Workbooks(1).ActiveSheet
           If num = 1 Then
               For G = 1 To Sheets.Count
                   Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1) 'Range("A65536").End(xlUp).Row表示最后一个非空单元格的行号
               Next
           Else
               For G = 1 To Sheets.Count
                   Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
               Next
           End If
           
           .Range("A65536").End(xlUp).Offset(1) = "    FileName:" + MyName  '记录工作簿名称，以示区分
           test = .Range("A65536").End(xlUp).Row
           .Range("A" & test & ":H" & test).Merge  '向右合并以工作簿名称为内容的单元格所在的8个单元格
           .Range("A65536").End(xlUp).Interior.Color = RGB(162, 233, 240)   '设置以工作簿名称为内容的单元格背景色，以示区分
           .Range("A65536").End(xlUp).Font.Size = 10
                
           WbN = WbN & Chr(13) & Wb.Name
           Wb.Close False
        End With
    End If
MyName = Dir
Loop

'============================ step1-2: 设置基础数据表样式  ============================

With Data.Range("A5").CurrentRegion
    .Rows(1).Interior.Color = RGB(0, 0, 128)   '设置表头背景色，以示区分
    .Rows(1).Font.Color = RGB(255, 255, 255)   '设置表头文字颜色，以示区分
    .HorizontalAlignment = xlLeft   '水平居左
    With .Borders
        .Color = RGB(0, 0, 0)  '边框颜色，黑色
        .LineStyle = xlContinuous  '边框线性，细线
        .Weight = xlMedium   '边框粗细，细
    End With
End With


'============================ step2: 筛选数据 ============================

Summary.Activate
Summary.Columns(1).ColumnWidth = 0.1
Summary.Columns(2).ColumnWidth = 23
Summary.Columns(3).ColumnWidth = 33


Const START_ROW = 3 '需要设置开始行0606

Summary.Cells(1, 2) = Data.Cells(2, 2)
Summary.Cells(1, 3) = Data.Cells(2, 6)
Summary.Cells(1, 1) = Data.Cells(2, 2) + Data.Cells(2, 6)
Summary.Rows(1).HorizontalAlignment = 4 '右对齐

Dim END_ROW As Integer
END_ROW = Data.Range("A65535").End(xlUp).Row

Dim i As Integer
Dim flag As Integer
flag = 0
Dim isError As Boolean
isError = False

Dim customerSN As String
Dim ownerN As String
Dim CsnandOn As String
Dim ObligationNumber As String
Dim CaNumber As String
Dim dbTime As String

For i = START_ROW To END_ROW Step 1
    customerSN = Trim(Data.Cells(i, 2).text) '0606 Customer Short Name
    ownerN = Trim(Data.Cells(i, 6).text) '0606 Owner Name
    ObligationNumber = Trim(Data.Cells(i, 3).text) '0609 Obligation Number
    CaNumber = Trim(Data.Cells(i, 4).text) '0609 Ca Number
    
    CsnandOn = customerSN + ownerN + ObligationNumber + CaNumber '0609 组合的唯一标识
    text = Trim(Data.Cells(i, 1).text) '0606判断是否到时间分隔点
    
    
    If Len(Trim(dbTime)) = 0 Then
        dbTime = Trim(Data.Cells(i, 8).text) '记录时间日期
    End If
    
    If Right(text, 5) <> ".xlsx" Then '尚未到时间分隔点

        Dim CsnandO As Range
        Set CsnandO = Summary.Cells.Find(what:=CsnandOn, LookIn:=xlValues) '查找已经存在的唯一标识

        
        If Not CsnandO Is Nothing Then   '判断已经存在情况
            Summary.Cells(CsnandO.Row, flag + 4) = Summary.Cells(CsnandO.Row, flag + 4) + Data.Cells(i, 7)
            
        Else '判断不存在情况
            Summary.Cells(Range("A65536").End(xlUp).Offset(1, 0).Row, 1) = CsnandOn
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 2) = customerSN
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 2).HorizontalAlignment = 4 '右对齐
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 3) = ownerN
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 3).HorizontalAlignment = 4 '右对齐
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, flag + 4) = Data.Cells(i, 7)
        End If
    Else   '每隔一个时间分割点，标志位加1
        Summary.Cells(1, flag + 4) = dbTime
        Summary.Columns(flag + 4).ColumnWidth = 14
        flag = flag + 1
        dbTime = ""
    End If
Next


'============================ step3: 求和、求平均数 ============================
Const HEADER_SUM = "sum"
Summary.Cells(1, flag + 4) = HEADER_SUM & "(" & flag & ")"
Const HEADER_AVG = "avg"
Summary.Cells(1, flag + 5) = HEADER_AVG & "(" & flag & ")"
Summary.Columns(flag + 4).ColumnWidth = 15  '设置求和列宽度
Summary.Columns(flag + 5).ColumnWidth = 15  '设置求均值列宽度

Dim j As Integer
Dim SUM_END_ROW As Integer
SUM_END_ROW = Summary.Range("A65535").End(xlUp).Row

Set st = Range("D2")
Set rt = st.Offset(0, flag - 1)
For j = 2 To SUM_END_ROW Step 1
    Summary.Cells(j, flag + 4).Formula = "=sum(" & st.Address & ":" & rt.Address & ")"
    Summary.Cells(j, flag + 5).Formula = "=" & st.Offset(0, flag).Address & "/" & flag
    Set st = st.Offset(1)
    Set rt = st.Offset(0, flag - 1)
Next


'============================ step3-2: 设置基础数据表样式  ============================
Summary.Rows().RowHeight = 15
Summary.Cells.Font.Name = "Arial"
Summary.Cells.Font.Size = 10
Summary.Rows(1).Font.Bold = True

With Summary.Range("A1").CurrentRegion
    .Rows(1).Interior.Color = RGB(0, 0, 128)   '设置表头背景色，以示区分
    .Rows(1).Font.Color = RGB(255, 255, 255)   '设置表头文字颜色，以示区分
    .HorizontalAlignment = xlLeft   '水平居左
    With .Borders
        .Color = RGB(0, 0, 0)  '边框颜色，黑色
        .LineStyle = xlContinuous  '边框线性，细线
        .Weight = xlMedium   '边框粗细，细
    End With
End With


'============================ step4: 提示或警告 ============================
Summary.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & num & "个工作薄下的全部工作表。如下：" & vbNewLine & WbN, vbInformation, "提示"

If isError Then
    Data.Activate
    Data.Range("A3").Select
    MsgBox "Error: 请确保文件目录只包含需要汇总的报表文件"
End If


ActiveWorkbook.Save 'Close Savechanges:=True
'Summary.Close Savechanges:=True

End Sub


心得体会：没有唯一主键，创建唯一值：CsnandOn

【推广】 免费学中医，健康全家人
原文地址：https://www.cnblogs.com/Elsie/p/3779795.html