汇总文件数据 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().Name = "BaseData"   '工作表命名，基础数据表
ActiveWorkbook.Worksheets().Name = "Summary"    '工作表命名，数据汇总以及计算表

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

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

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

num =
Dim test As Long

'============================ step1: 准备基础数据，整合到一张工作薄中的一张工作表 ============================
Do While MyName <> ""
    If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "\" & MyName)    '打开文件
        num = num + 

        With Workbooks().ActiveSheet
           If num =  Then
               For G =  To Sheets.Count
                   Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + , ) 'Range("A65536").End(xlUp).Row表示最后一个非空单元格的行号
               Next
           Else
               For G =  To Sheets.Count
                   Wb.Sheets(G).UsedRange.Offset(, ).Copy .Cells(.Range("A65536").End(xlUp).Row + , )
               Next
           End If

           .Range("A65536").End(xlUp).Offset() = "    FileName:" + MyName  '记录工作簿名称，以示区分
           test = .Range("A65536").End(xlUp).Row
           .Range("A" & test & ":H" & test).Merge  '向右合并以工作簿名称为内容的单元格所在的8个单元格
           .Range("A65536").End(xlUp).Interior.Color = RGB(, , )   '设置以工作簿名称为内容的单元格背景色，以示区分
           .Range("A65536").End(xlUp).Font.Size = 

           WbN = WbN & Chr() & Wb.Name
           Wb.Close False
        End With
    End If
MyName = Dir
Loop

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

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

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

Summary.Activate
Summary.Columns().ColumnWidth = 0.1
Summary.Columns().ColumnWidth =
Summary.Columns().ColumnWidth = 

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

Summary.Cells(, ) = Data.Cells(, )
Summary.Cells(, ) = Data.Cells(, )
Summary.Cells(, ) = Data.Cells(, ) + Data.Cells(, )
Summary.Rows().HorizontalAlignment =  '右对齐

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

Dim i As Integer
Dim flag As Integer
flag =
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
    customerSN = Trim(Data.Cells(i, ).text) '0606 Customer Short Name
    ownerN = Trim(Data.Cells(i, ).text) '0606 Owner Name
    ObligationNumber = Trim(Data.Cells(i, ).text) '0609 Obligation Number
    CaNumber = Trim(Data.Cells(i, ).text) '0609 Ca Number

    CsnandOn = customerSN + ownerN + ObligationNumber + CaNumber '0609 组合的唯一标识
    text = Trim(Data.Cells(i, ).text) '0606判断是否到时间分隔点

    If Len(Trim(dbTime)) =  Then
        dbTime = Trim(Data.Cells(i, ).text) '记录时间日期
    End If

    If Right(text, ) <> ".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 + ) = Summary.Cells(CsnandO.Row, flag + ) + Data.Cells(i, )

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

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

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(, flag - )
For j =  To SUM_END_ROW Step
    Summary.Cells(j, flag + ).Formula = "=sum(" & st.Address & ":" & rt.Address & ")"
    Summary.Cells(j, flag + ).Formula = "=" & st.Offset(, flag).Address & "/" & flag
    Set st = st.Offset()
    Set rt = st.Offset(, flag - )
Next

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

With Summary.Range("A1").CurrentRegion
    .Rows().Interior.Color = RGB(, , )   '设置表头背景色，以示区分
    .Rows().Font.Color = RGB(, , )   '设置表头文字颜色，以示区分
    .HorizontalAlignment = xlLeft   '水平居左
    With .Borders
        .Color = RGB(, , )  '边框颜色，黑色
        .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