多工作簿多个工作表，全部数据汇总

快人一步 · 发表于 2024-12-10 22:47

Sub 根据客户统计男女个数及余额()
Dim X As Long
Dim conn As Object
Dim Sql As String
Dim rs As Object
Dim ws As Worksheet
Dim lastRow As Long

' 设置工作表
Set ws = ThisWorkbook.Sheets("Sheet1") ' 假设结果输出到当前工作表

' 清除之前的内容
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A2:F" & lastRow).ClearContents

' 创建数据库连接
Set conn = CreateObject("ADODB.Connection")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & ThisWorkbook.Path & "\数据.xlsx;" & _
            "Extended Properties='Excel 12.0 Xml;HDR=YES';"

' 统计机构下男女个数及余额的SQL
Sql = "SELECT 机构名称, 机构号, 身份证号, 性别, COUNT(*) AS 个数, SUM(余额) AS 总余额 " & _
      "FROM [Sheet1$] " & _
      "GROUP BY 机构名称, 机构号, 身份证号, 性别 " & _
      "ORDER BY 机构名称, 机构号, 身份证号, 性别"

' 执行SQL查询
Set rs = conn.Execute(Sql)

' 如果查询返回了结果集
If Not rs.EOF Then
      ' 将结果集复制到工作表
      ws.Range("a2").CopyFromRecordset rs
End If

' 关闭记录集和连接
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub

我这段代码只能统计一个工作表的数据，请各位师傅帮我修改在同一个文件夹下统计所有工作簿中所有工作表，如附件中合计汇总，谢谢！

cnmlgb9998 · 发表于 2024-12-11 01:18

是这个效果？？？？？？？？？？？？？？

PQ 解决方案

z865593849 · 发表于 2024-12-11 08:28

这个要有附件才好处理

ykcbf1100 · 发表于 2024-12-11 08:30

本帖最后由 ykcbf1100 于 2024-12-11 08:58 编辑

附件供参考。。。

ykcbf1100 · 发表于 2024-12-11 08:32

本帖最后由 ykcbf1100 于 2024-12-11 08:59 编辑

此题要点是从身份证号中提取性别和年龄

Sub ykcbf() '//2024.12.11
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("结果")
ReDim brr(1 To 100, 1 To 4)
For Each sht In Sheets
If sht.Name <> sh.Name Then
With sht
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 6)
End With
For i = 2 To UBound(arr)
id = CStr(arr(i, 2))
Call IDInfo(id, zr)
Select Case zr(3)
Case Is <= 30
m = 1
Case Is <= 40
m = 2
Case Is <= 50
m = 3
Case Is <= 60
m = 4
Case Else
m = 5
End Select
brr(m, 1) = brr(m, 1) + IIf(zr(1) = "男", 1, 0)
brr(m, 2) = brr(m, 2) + IIf(zr(1) = "女", 1, 0)
brr(m, 3) = brr(m, 3) + IIf(zr(1) = "男", arr(i, 6), 0)
brr(m, 4) = brr(m, 4) + IIf(zr(1) = "女", arr(i, 6), 0)
Next
End If
Next
sh.[c2].Resize(5, 4) = brr
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-12-11 08:34

1楼代码能出正确结果？性别数据是从哪来的？分表中根本没有性别列。

翁知江安 · 发表于 2024-12-11 09:16

Sub hz()
Dim i, t, y, yy, kk, m, n, p, q, s, a, irow, icolumn
Dim tepar, ar, br, cr
Dim sht As Worksheet
Dim tt
tt = Timer
Dim d1, d2, d3 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
For Each sht In Sheets
  If sht.Name <> "结果" Then
  irow = sht.[a65536].End(xlUp).Row
  tepar = sht.[a1].Resize(irow, 8)
  For i = 2 To irow
  s = Val(Mid(tepar(i, 2), 17, 1))
  If s Mod 2 = 1 Then
tepar(i, 7) = "男"
   Else
   tepar(i, 7) = "女"
End If
t = Val(Mid(tepar(i, 2), 7, 4))
y = Year(Now())
yy = y - t
If yy <= 30 Then
   tepar(i, 8) = "0-30"
   Else
      If yy <= 40 Then
   tepar(i, 8) = "31-40"
      Else
      If yy <= 50 Then
      tepar(i, 8) = "41-50"
      Else
      If yy <= 60 Then
      tepar(i, 8) = "51-60"
         Else
         tepar(i, 8) = "60以上"
      End If
   End If
   End If
End If
d1(tepar(i, 1) & tepar(i, 8) & tepar(i, 7)) = d1(tepar(i, 1) & tepar(i, 8) & tepar(i, 7)) + 1
d2(tepar(i, 1) & tepar(i, 8) & tepar(i, 7)) = d2(tepar(i, 1) & tepar(i, 8) & tepar(i, 7)) + tepar(i, 6)
d3(tepar(i, 1) & "," & tepar(i, 8)) = ""
Next
End If
Next

ReDim ar(1 To d3.Count, 1 To 2)
For Each kk In d3.keys
m = m + 1
For n = 1 To 2
ar(m, n) = Split(kk, ",")(n - 1)
Next
Next
Sheets("结果").[a2].Resize(100, 2).ClearContents
Sheets("结果").[a2].Resize(m, 2) = ar
br = Sheets("结果").[a1].Resize(1 + m, 6)
ReDim cr(1 To m, 1 To 4)
For p = 2 To m + 1
For q = 3 To 4
   cr(p - 1, q - 2) = d1(br(p, 1) & br(p, 2) & Left(br(1, q), 1))
Next
For q = 5 To 6
   cr(p - 1, q - 2) = d2(br(p, 1) & br(p, 2) & Left(br(1, q), 1))
Next
Next
Sheets("结果").[c2].Resize(100, 4).ClearContents
Sheets("结果").[c2].Resize(m, 4) = cr
MsgBox Timer - tt
MsgBox "ok"
End Sub

翁知江安 · 发表于 2024-12-11 09:18

供参考，欢迎批评指正

cnmlgb9998 · 发表于 2024-12-11 11:04

更新了一下代码，实现小计及总计。

是这个效果吗？好就上花！

let
源 = Table.SelectRows(
Excel.Workbook(File.Contents("C:\Users\飞飞\Desktop\VBA\12-11-1.xlsx"), null, true),
each [Name] <> "结果"
)[Data],
Tab1 = Table.SelectRows(
Table.SelectColumns(
Table.Combine(List.Transform(源, each Table.PromoteHeaders(_))),
{"机构", "身份证号码", "收入"}
),
each [机构] <> null
),
fx = (R) =>
[
a = Text.From(R{1}),
Year = Number.From(Text.Range(a, 6, 4)),
Mon = Number.From(Text.Range(a, 10, 2)),
Day = Number.From(Text.Range(a, 12, 2)),
Old = Number.Round(
Duration.TotalDays(
Date.From(DateTime.FixedLocalNow()) - Date.From(#date(Year, Mon, Day))
)
/ 365,
2
),
gx = (S, T) =>
if T < 30 then
"0-30"
else if S > T then
Text.Format("#{0}-#{1}", {Text.From(T + 1), Text.From(T + 10)})
else
@gx(S, T - 10),
O = gx(Old, 60),
Sex = if Number.IsEven(Number.From(Text.Range(a, 16, 1))) then "女" else "男",
H = {R{0}, O, Sex, R{2}}
][H],
Lst = List.Transform(Table.ToRows(Tab1), each fx(_)),
Tab2 = Table.FromRows(Lst),
Group = Table.Group(
Tab2,
"Column1",
{
"c",
(z) =>
Table.Group(
z,
"Column2",
{
"d",
each [
Mal = List.Count(List.Select([Column3], (x) => x = "男")),
Fam = List.Count([Column3]) - Mal,
MM = List.Sum(
Table.SelectRows(_, (y) => y[Column3] = "男")[
Column4
]
),
FM = List.Sum([Column4]) - MM,
k = Table.FromRows(
{{Mal, Fam, MM, FM}},
{"男数", "女数", "男收", "女收"}
)
][k]
}
)
}
),
Expand = Table.TransformColumns(
Group,
{
"c",
each [
a = Table.Sort(
Table.ExpandTableColumn(_, "d", {"男数", "女数", "男收", "女收"}),
{(x) => Text.BeforeDelimiter(x[Column2], "-"), 0}
),
b = Table.Group(
a,
{},
List.Transform(
Table.ColumnNames(a),
(y) =>
{y, (z) => try List.Sum(Table.Column(a, y)) otherwise "小计"}
)
),
c = a & b
][c]
}
),
Res = [
a = Table.ExpandTableColumn(Expand, "c", {"Column2", "男数", "女数", "男收", "女收"}),
b = Table.SelectRows(a, each [Column2] = "小计"),
c = Table.Group(
b,
{},
List.Transform(
List.Skip(Table.ColumnNames(b)),
each {_, (x) => try List.Sum(Table.Column(b, _)) otherwise "总计"}
)
),
d = a & c
][d]
in
Res

复制代码

快人一步 · 发表于 2024-12-11 12:50

本帖最后由快人一步于 2024-12-11 12:51 编辑

多谢各位师傅，无意思上错附件，现重新上传。

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

[求助] 多工作簿多个工作表，全部数据汇总