月汇总工作表 VBA

时间：2014-06-11 21:56:24 收藏：0 阅读：398
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
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 & "\" & "*.xls")
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
 
Const 
NUM_WIDTH = 9
Const 
NAME_WIDTH1 = 50
Const 
NAME_WIDTH2 = 3
 
Data.Columns(1).ColumnWidth = NUM_WIDTH    ‘设置第 1 列宽度
Data.Columns(2).ColumnWidth = NAME_WIDTH1    ‘设置第 2 列宽度
Data.Columns(3).ColumnWidth = NAME_WIDTH2    ‘设置第 3 列宽度
Data.Columns(4).ColumnWidth = 17    ‘设置第 4 列宽度
Data.Columns(5).ColumnWidth = 5    ‘设置第 5 列宽度
Data.Columns(6).ColumnWidth = 12    ‘设置第 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(4, 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 & ":F" 
& test).Merge  ‘向右合并以工作簿名称为内容的单元格所在的6个单元格
           .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: 设置基础数据表样式  ============================
Data.Range("A1").Select
Data.Rows().RowHeight = 15
Data.Cells.Font.Name = "Arial"
Data.Range("A3:F3").Merge
Data.Range("A3") = Replace(Data.Range("A3").text, "Daily", "")
 
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 = NUM_WIDTH
Summary.Columns(2).ColumnWidth = NAME_WIDTH1 + NAME_WIDTH2
 
Const 
START_ROW = 6
 
Summary.Cells(1, 1) = Data.Cells(5, 1)
Summary.Cells(1, 2) = Data.Cells(5, 2)
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 
text As 
String
Dim 
dbTime As 
String
 
For 
i = START_ROW To 
END_ROW Step 
1
    text = Trim(Data.Cells(i, 1).text)
      
    If 
Len(Trim(dbTime)) = 0 Then
        dbTime = Trim(Data.Cells(i, 6).text)
    End 
If
     
    If 
Right(text, 4) <> ".xls" 
Then ‘尚未到时间分隔点
        Dim 
myrange As 
Range
        Set 
myrange = Summary.Cells.Find(what:=text, LookIn:=xlValues)
        If 
Not myrange Is 
Nothing Then   ‘dir num已经存在
           Summary.Cells(myrange.Row, flag + 3) = Data.Cells(i, 4)
           If 
Summary.Cells(myrange.Row, 2) <> Data.Cells(i, 2) Then
                Summary.Cells(myrange.Row, 2).Interior.ColorIndex = 3
                Data.Cells(i, 2).Interior.ColorIndex = 3
                isError = True
           End 
If
        Else   
‘dir num不存在
            Summary.Cells(Range("A65536").End(xlUp).Offset(1, 0).Row, 1) = text
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 2) = Data.Cells(i, 2)
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, 2).HorizontalAlignment = 4 ‘右对齐
            Summary.Cells(Range("A65536").End(xlUp).Offset(0, 0).Row, flag + 3) = Data.Cells(i, 4)
        End 
If
    Else   
‘每隔一个时间分割点，标志位加1
        Summary.Cells(1, flag + 3) = dbTime
        Summary.Columns(flag + 3).ColumnWidth = 14
        flag = flag + 1
        dbTime = ""
    End 
If
Next
 
 
‘============================ step3: 求和、求平均数 ============================
Const 
HEADER_SUM = "sum"
Summary.Cells(1, flag + 3) = HEADER_SUM & "(" 
& flag & ")"
Const 
HEADER_AVG = "avg"
Summary.Cells(1, flag + 4) = HEADER_AVG & "(" 
& flag & ")"
Summary.Columns(flag + 3).ColumnWidth = 15  ‘设置求和列宽度
Summary.Columns(flag + 4).ColumnWidth = 15  ‘设置求均值列宽度
 
Dim 
j As Integer
Dim 
SUM_END_ROW As 
Integer
SUM_END_ROW = Summary.Range("A65535").End(xlUp).Row
 
Set 
st = Range("C2")
Set 
rt = st.Offset(0, flag - 1)
For 
j = 2 To 
SUM_END_ROW Step 
1
    Summary.Cells(j, flag + 3).Formula = "=sum(" 
& st.Address & ":" 
& rt.Address & ")"
    Summary.Cells(j, flag + 4).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:" 
& vbNewLine & vbNewLine & "Dealer Name出现不一致的情况！" 
& vbNewLine & "请查看红色高亮的部分！", vbExclamation, "警告"
End 
If
 
 
ActiveWorkbook.Save ‘Close Savechanges:=True
‘Summary.Close Savechanges:=True
 
End 
Sub
月汇总工作表 VBA,布布扣,bubuko.com