汇总

sulli112 · 发表于 2021-6-4 11:01

1.工作簿中按照特定关键词隐藏个别工作表http://club.excelhome.net/thread-1580045-1-1.html
2.多个工作簿合并
http://club.excelhome.net/thread-1580012-1-1.html
3.根据汇总表自动匹配数据到对应表名对应标题，以及数据汇总
http://club.excelhome.net/thread-1576867-1-1.html
4.每个工作表中在某一列自动生成序号
http://club.excelhome.net/thread-1576627-1-1.html
5.数据快速录入设置
http://club.excelhome.net/thread-1576390-1-1.html
6.有关批量打印设置
http://club.excelhome.net/thread-1575654-1-1.html
7.提取阿拉伯数字以及大写数字，或者按照特定拼音转为特定中文
http://club.excelhome.net/thread-1575130-2-1.html
8.当表一ABC三列条件一致时，汇总金额到汇总表，并且要合并E列文字到汇总表
http://club.excelhome.net/thread-1571903-1-1.html
9.同一文件夹下，多层子文件夹工作簿汇总在总表里面
http://club.excelhome.net/thread-1558181-2-1.html
10.多个工作表中将某一列求和将值罗列在汇总表中（形式：表名+求和值）
http://club.excelhome.net/thread-1557488-1-1.html
11.在inputbox输入某时间段，系统可以自动汇总在其他表中B列日期包括等于这段时间段内的数据到汇总表中
http://club.excelhome.net/thread-1552794-1-1.html
12.以人名为关键字眼，将每个表中的数据汇总累计相加到对应位置（标题）
http://club.excelhome.net/thread-1549958-1-1.html
13.统计某个关键词在哪些表中出现过多少次
http://club.excelhome.net/thread-1548953-1-1.html
14.统计101-109班的学生某些项目金额出现的次数
http://club.excelhome.net/thread-1542774-1-1.html
15.除汇总表外，选中背景颜色为红色的所有行，粘贴在汇总表里面
http://club.excelhome.net/thread-1538666-1-1.html
16.A:根据汇总表D列的（班级）匹配到对应表名，并且在找到的对应表里面，匹配到姓名一致那一栏
B:将汇总表的数据按照各个表的抬头，将其复制到对应位置
http://club.excelhome.net/thread-1537283-1-1.html
17.当J列不等于935，或者“”值时，将不相等单元格标黄
http://club.excelhome.net/thread-1534397-1-1.html
18.统计所有表格名称及各项目出现次数

Sub 统计()
Dim i&, k&
Sheets.Add.Name = "汇总"
Dim ws As Worksheet
Worksheets("汇总").Range("A2", Range("A65536").End(xlUp)).ClearContents '单元格的公式，但保留其格式设置
For Each ws In Worksheets
If ws.Name <> "汇总表"and ws.Name <> "汇总"And ws.Visible = -1Then
k = k + 1
Cells(k + 1, 1) = ws.Name
Cells(k + 1, 2) = ws.Range("A65536").End(xlUp).Row - 1
Cells(k + 1, 3) =Application.WorksheetFunction.Count(ws.Columns("f")) '早餐
Cells(k + 1, 4) =Application.WorksheetFunction.Count(ws.Columns("g")) '中餐
Cells(k + 1, 5) =Application.WorksheetFunction.Count(ws.Columns("h")) ’晚餐
Cells(k + 1, 6) =Application.WorksheetFunction.Count(ws.Columns("i")) ’车费
End If
Next
End Sub
如果想统计哪一列需要这个的人数为多少人
把这句：Cells(k + 1, 2) = ws.Range("A65536").End(xlUp).Row - 1
改成：
Cells(k + 1, 3) =Application.WorksheetFunction.Count(ws.Columns("f")) '早餐
Cells(k + 1, 4) =Application.WorksheetFunction.Count(ws.Columns("g")) '中餐
Cells(k + 1, 5) =Application.WorksheetFunction.Count(ws.Columns("h")) ’晚餐
Cells(k + 1, 6) =Application.WorksheetFunction.Count(ws.Columns("i")) ’车费

复制代码

19.忽略空值，根据某一列拆分表格

Sub 根据列内容拆分数据表()
Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer
Dim sht0 As Worksheet
Set sht0 = ActiveSheet
Range("a1", "a" & [a65536].End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete '当第一行为空值时删除整行
l = InputBox("要按第几列拆分")
'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
For Each sht1 In Sheets
If sht1.Name <> sht0.Name Then
sht1.Delete
End If
Next
End If
Application.DisplayAlerts = True
irow = sht0.Range("a65536").End(xlUp).Row
'拆分表
For i = 2 To irow
k = 0
For Each sht In Sheets
If sht.Name = sht0.Cells(i, l) Then
k = 1
End If
Next
If k = 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sht0.Cells(i, l)
End If
Next
'拷贝数据
For j = 2 To Sheets.Count
sht0.Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
sht0.Range("a1:z" & irow).Copy Sheets(j).Range("a1")
Next
sht0.Range("a1:z" & irow).AutoFilter
sht0.Select
MsgBox "已处理完毕！"
End Sub

复制代码

20.多表合并为一表

'''多表合并一表
Sub 合并()
Dim wsh As Worksheet, brr(), i As Integer, k As Integer, arr
Sheets("汇总表").Range("a2:t9999").Clear
For Each wsh In Worksheets
If wsh.Name <> "汇总表" Then
arr = wsh.Range("a2:t" & wsh.Range("a65536").End(xlUp).Row)
k = k + UBound(arr)
ReDim Preserve brr(1 To 20, 1 To k)
For i = 1 To UBound(arr)
n = n + 1
brr(1, n) = arr(i, 1)
brr(2, n) = arr(i, 2)
brr(3, n) = arr(i, 3)
brr(4, n) = arr(i, 4)
brr(5, n) = arr(i, 5)
brr(6, n) = arr(i, 6)
brr(7, n) = arr(i, 7)
brr(8, n) = arr(i, 8)
brr(9, n) = arr(i, 9)
brr(10, n) = arr(i, 10)
brr(11, n) = arr(i, 11)
brr(12, n) = arr(i, 12)
brr(13, n) = arr(i, 13)
brr(14, n) = arr(i, 14)
brr(15, n) = arr(i, 15)
brr(16, n) = arr(i, 16)
brr(17, n) = arr(i, 17)
brr(18, n) = arr(i, 18)
brr(19, n) = arr(i, 19)
brr(20, n) = arr(i, 20)
Next
End If
Next
Sheets("汇总表").Range("a2").Resize(UBound(brr, 2), 20) = Application.Transpose(brr)
End Sub

复制代码

21.表格排序

Sub 表格排序()
Dim i%, j%
'比如 dim s as string '显式声明 s = "abcd" s$ = "abcd" '隐式声明,integer % 短整型
For i = 1 To Sheets.Count-1
For j =1 To Sheets.Count-1
If Sheets(j).Name>=Sheets(j+1).Name Then
Sheets(j).Move after:=Sheets(j+1)
End If
Next j
Next i
Sheets(1).Select
End Sub

复制代码

22.删除背景为红色的所有行

Sub 删除红色背景的行()
For i = 2 To Sheets.Count
With Sheets(i)
R = .Cells(Rows.Count, 2).End(xlUp).Row
For j = 1 To R
If .Cells(j, 2).Interior.Color = 255 Then .Cells(j, 2).EntireRow.Delete
Next
End With
Next
End Sub

复制代码

23.自动拆分工作表到同一目录中

Sub 自动拆分工作表到同一目录中()
'
' 自动拆分工作表宏
'
' 快捷键: Ctrl+m
'
'把各个工作表以单独的工作簿文件保存在本工作簿所在的文件夹下的“拆分工作簿”文件夹下
'获取活动工作簿所在路径并判断该路径下是否存在文件夹"拆分工作簿",如果不存在则创建
'遍历活动工作簿中的每个工作表，复制并另存为新的工作簿，工作簿文件名以工作表名称命名
'如果遇到隐藏工作表，则先打开隐藏，复制并另存为后关闭隐藏
'
Application.ScreenUpdating = False '关闭屏幕更新
Dim xpath, isNext As String
Dim sht As Worksheet
xpath = Application.ActiveWorkbook.Path & "\拆分工作簿"
If Len(Dir(xpath, vbDirectory)) = 0 Then MkDir xpath '如果文件夹不存在，则新建文件夹
For Each sht In Worksheets
If sht.Visible = False Then
'MsgBox "有隐藏工作表" & sht.Name
'隐藏工作表是否拆分
isNext = InputBox("1:跳过不处理" & Chr(10) & "2:处理并保持隐藏" & Chr(10) & "3:处理并取消隐藏" & Chr(10) & "空:不输入或其他值则默认不执行", "【" & sht.Name & "】为隐藏工作表,请选择执行方式")
If isNext = 2 Or isNext = 3 Then
sht.Visible = True '取消工作表的隐藏
sht.Copy
ActiveWorkbook.SaveAs Filename:=xpath & "" & sht.Name & ".xlsx"
ActiveWorkbook.Close
If isNext = 2 Then
sht.Visible = False '恢复工作表的隐藏
End If
End If
ElseIf sht.Visible = True Then
sht.Copy
ActiveWorkbook.SaveAs Filename:=xpath & "" & sht.Name & ".xlsx"
ActiveWorkbook.Close
End If
Next
'MsgBox "工作簿拆分结束"
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

复制代码

24.如果两个表格数据不一致，会在表中标明不一致

sulli112 · 发表于 2021-9-17 13:54

24.根据数据计算加班时间https://club.excelhome.net/thread-1593790-1-1.html
25根据关键字，提取数据，并且汇总相加https://club.excelhome.net/thread-1594816-1-1.html.
26.根据日期先后顺序，找出最相近的值，罗列出来（根据数据，选出相近的数据相加等于唯一值或者近似值）https://club.excelhome.net/thread-1595610-1-1.html

sulli112 · 发表于 2021-9-24 15:08

27.复制整个表格的时候，保留原宽度跟隐藏的行列，只去掉某一个表格的公式

Sub fmlatoval()
Dim a As Worksheet
For Each a In Sheets
If a.Name <> "工资条" Then 'a代表了工作表
a.UsedRange.Copy 'UsedRange表示所有被编辑过的单元格
a.UsedRange.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next
End Sub

复制代码

hellikawhi2 · 发表于 2021-9-24 15:23

感谢分享,mark

dengcaimao · 发表于 2021-9-25 07:10

感谢楼主的分享

sulli112 · 发表于 2021-9-25 10:54

hellikawhi2 发表于 2021-9-24 15:23
感谢分享,mark

我原意是打算，将所有求助过的帖子整合起来，方便查询，不过能帮到大家我还是很开心的

sulli112 · 发表于 2021-9-25 10:55

dengcaimao 发表于 2021-9-25 07:10
感谢楼主的分享

我原意是打算，将所有求助过的帖子整合起来，方便查询，不过能帮到大家我还是很开心的

sulli112 · 发表于 2021-10-13 14:37

28.根据表格，将对应标题的数据根据标题汇总到同一表中，提取数据的标题有横竖排列https://club.excelhome.net/thread-1602085-1-1.html

sulli112 · 发表于 2022-2-25 13:44

29.根据货品编码，读取数据到另一货品编码中，其中被取数据的货品编码有分号，类似1002-001/1002-002，可以将数据汇总到取数货品编码1002中https://club.excelhome.net/thread-1605023-1-1.html

sulli112 · 发表于 2022-2-25 13:45

30.根据要求提取数据，同时数据随客户变动而变动https://club.excelhome.net/thread-1617574-1-1.html

		自动登录	找回密码
密码			免费注册

[分享] 汇总

评分