陆续更新中,常用复杂操作。

一、目录：

1.多工作簿数据合并计算

2.VBA-简单表格内容汇总

3.VBA-多条件多列条件汇总

4.多列文本格式快速调整为数值格式

5.工资条自动生成

6.按照数据类型分类，将工作簿拆分成多个工作表

7.将不同分类的数据保存到新工作表中

---

二、内容：

1.多工作簿数据合并计算（如需跨工作簿进行计算，必须将所有需要合并计算工作簿打开）

举例：将各分地区数据进行加总得到全辖数据（所有表样需一致）

S1:打开所有工作表

S2：在汇总表中选择需要加总区域

S3:数据-合并计算-引用位置-浏览（选择某个需要加总工作表对应区域，）-添加

将所有需要加总的表填加到引用位置处，勾选创建指向源数据的链接，单击确定（如选择区域包含表头等，请勾选首行、最左列）

2.VBA-简单表格内容汇总

实现形式：将不同工作簿的内容汇总到同一工作表下

方法：EXCEL -开发工具-VBA编辑器

    Sub HZWB()  
        Dim BT As Range, R As Long, C As Long
        R = 4    '表头的行数
        C = 18   '表头的列数
        Range(Cells(R + 1, "A"), Cells(65536, C)).ClearContents '清除原表中数据
        Application.ScreenUpdating = False
        Filename = Dir(ThisWorkbook.Path & "\*.xls")
        Do While Filename <> ""
                If Filename <> ThisWorkbook.Name Then
                      erow =Range("A1").CurrentRegion.Rows.Count + 1 '判断是否为本工作簿
                      fn = ThisWorkbook.Path &"\" & Filename        '取得汇总表中第一行空行行号
                      Set wb = GetObject(fn)                '将fn代表的工作簿对象赋给变量
                      Set sht = wb.Worksheets(1)         '汇总第一张工作表
                      arr = sht.Range(sht.Cells(R,"a"), sht.Cells(65536, "b").End(xlUp).Offset(0, 18)) '将数据表中记录保存在arr数组中
                    Cells(erow,"a").Resize(UBound(arr, 1), UBound(arr, 2)) = arr       '将数组中数据写入工作表
                    wb.Close False
                End If
                Filename = Dir       '取得其他文件名并赋予变量
        Loop
        Application.ScreenUpdating = True    
    End Sub

3.VBA-多条件多列汇总

实现形式：根据多个筛选条件，汇总多条件值。

Sub 下棋法之多条件多列汇总()
Dim 汇总表(1 To 10000, 1 To 3)  '汇总表大小
 Dim 行数Dim arr, x As Integer, sr As String, k As IntegerDim d As New Dictionary
    arr = Range("a2:s" & Range("a65536").End(xlUp).Row)  ’汇总数据范围
    For x = 1 To UBound(arr)  
       sr = arr(x, 4) & "-" & arr(x, 9)  '多列判断区域条件，比如此处为根据第4列和第9列条件进行汇总  
       If d.Exists(sr) Then   
            行数 = d(sr)   
            汇总表(行数, 3) = 汇总表(行数, 3) + arr(x, 14) ‘汇总表中第三列数字累    计，因为第14列为原表中数字列，所以是arr（x，14） 
       Else  
           k = k + 1   
           d(sr) = k   
          汇总表(k, 1) = arr(x, 4)     '汇总表中数据列   
          汇总表(k, 2) = arr(x, 9)  
          汇总表(k, 3) = arr(x, 14)    
      End If
    Next x 
  Range("U2").Resize(k, 3) = 汇总表  ’汇总表首行查所在位置
End Sub

4.多列文本格式快速调整为数值格式

当面临多列数值同时需要从文本格式转换成数值格式时，分列就显得效率太低。参考处理方法如下:

1.复制空白列

2.全选需要更改数字格式列

3.选择性粘贴，运算选:加

5.工资条自动生成

效果：每行自动插入表头，制作工资条效果

Sub 批量复制表头()
    
    dim a as long
    For a = 2 To 164   '数据从第几行到第几行
    ActiveCell.Rows("1:1").EntireRow.Select
    Selection.Copy
    ActiveCell.Offset(2, 0).Rows("1:1").EntireRow.Select
   Selection.Insert Shift:=xlDown
   Next
End Sub

6.按照数据类型分类，将工作簿拆分成多个工作表

Sub pro()
添加
删除
复制
End Sub


Sub 添加()
    i = 2 '数据从第二行开始
Set sht = Worksheets("Sheet1")  '第一张表
Do While sht.Cells(i, "b").Value <> ""  'B列为空值结束
On Error Resume Next  '当没有对应的工作表时，忽略下一行代码
If Worksheets(sht.Cells(i, "b").Value) Is Nothing Then  '判断是否存在对应工作表
Worksheets.add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sht.Cells(i, "b").Value  '以B列的名字建立新的工作表
End If
i = i + 1
   Loop
End Sub



Sub 删除()
For Each sht In Worksheets
If sht.Name <> "Sheet1" Then
sht.Range("A2:G65536").ClearContents
sht.Range("A1: F1").Value = Sheet1.Range("A1: F1").Value
End If
Next
End Sub



Sub 复制()
i = 2
bj = Sheet1.Cells(i, "b").Value
Do While bj <> ""
    Set rng = Worksheets(bj).Range("a65536").End(xlUp).Offset(1, 0) '将分表中A列第一个空单元格赋给rng
    Sheet1.Cells(i, "a").Resize(1, 6).copy rng '将记录复制在相应表中
    i = i + 1
    bj = Sheet1.Cells(i, "b").Value
Loop

End Sub

---

7.将不同分类的数据保存到新工作表中

Sub 将工作表保存为新工作簿()
    Application.ScreenUpdating = False '关闭屏幕更新
    Dim folder As String
    folder = ThisWorkbook.Path & "\批量分割"
    If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
                                                      '如果文件夹不存在，新建文件夹 。使用Mkdir 新建文件夹。folder指定路径
    Dim sht As Worksheet
    For Each sht In Worksheets  '遍历工作簿
        sht.copy                '复制工作簿到新的工作簿
        ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xls" '保存工作簿并重命名
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
End Sub