提取数据到汇总表

1565785678

老师们，将各公司资产负债表中资产合计和负债合计及利润表中的收入和利润数据复制到汇总表中的相应单元格。

yanglinzi

1. Sub 取数()
   
2. Dim arr, brr, i, j, r, sht
   
3. ReDim brr(1 To 1000, 1 To 5)
   
4. For Each sht In Sheets
   
5.     If InStr(sht.Name, "资产负债表") Then
   
6.         n = n + 1
   
7.         brr(n, 1) = n
   
8.         brr(n, 2) = sht.Cells(36, 3)
   
9.         brr(n, 3) = sht.Cells(27, 7)
   
10.     ElseIf InStr(sht.Name, "利润表") Then
    
11.         brr(n, 4) = sht.Cells(5, 3)
    
12.         brr(n, 5) = sht.Cells(36, 3)
    
13.     End If
    
14. Next
    
15. Sheet1.[a2].Resize(n, 5) = brr
    
16. End Sub
    

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim reg As New RegExp
   
6.     With reg
   
7.         .Global = False
   
8.         .Pattern = "(\d+)(资产负债表|利润表)"
   
9.     End With
   
10.     ReDim brr(1 To 1000, 1 To 5)
    
11.     m = 0
    
12.     For Each ws In Worksheets
    
13.         Set mh = reg.Execute(ws.Name)
    
14.         If mh.Count > 0 Then
    
15.             xh = Val(mh(0).SubMatches(0))
    
16.             mc = mh(0).SubMatches(1)
    
17.             With ws
    
18.                 If mc = "资产负债表" Then
    
19.                     m = m + 1
    
20.                     brr(xh, 1) = m
    
21.                     brr(xh, 2) = .Range("c36")
    
22.                     brr(xh, 3) = .Range("g27")
    
23.                 Else
    
24.                     brr(xh, 4) = .Range("c5")
    
25.                     brr(xh, 5) = .Range("c36")
    
26.                 End If
    
27.             End With
    
28.         End If
    
29.     Next
    
30.     With Worksheets("汇总表")
    
31.         .UsedRange.Offset(1, 0).Clear
    
32.         .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
33.     End With
    
34. End Sub
    

复制代码

chxw68

参与一下。

yanglinzi

不知是不是你要的结果

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()  '//2024.4.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set ws = ThisWorkbook
   
5.     Set sh = ws.Sheets("汇总表")
   
6.     fn = [{"资产负债表","利润表"}]
   
7.     b = [{"资产总计","负债合计","营业收入","净利润"}]
   
8.     Dim tm: tm = Timer
   
9.     ReDim brr(1 To 1000, 1 To 5)
   
10.     On Error Resume Next
    
11.     For Each sht In Sheets
    
12.         If sht.Name <> sh.Name Then
    
13.                 If InStr(sht.Name, fn(1)) Then
    
14.                     With sht
    
15.                         m = m + 1
    
16.                         brr(m, 1) = m
    
17.                         r1 = .Columns(1).Find(b(1), LookIn:=xlValues).Row
    
18.                         r2 = .Columns(5).Find(b(2), LookIn:=xlValues).Row
    
19.                         brr(m, 2) = .Cells(r1, 3)
    
20.                         brr(m, 3) = .Cells(r2, 7)
    
21.                     End With
    
22.                 Else
    
23.                     With sht
    
24.                         r1 = .Columns(1).Find(b(3), LookIn:=xlValues).Row
    
25.                         r2 = .Columns(1).Find(b(4), LookIn:=xlValues).Row
    
26.                         brr(m, 4) = .Cells(r1, 3)
    
27.                         brr(m, 5) = .Cells(r2, 3)
    
28.                     End With
    
29.                 End If
    
30.         End If
    
31.     Next
    
32.     With sh
    
33.         .[a2:e1000] = ""
    
34.         .[a1].Resize(1, 5).Interior.Color = 49407
    
35.         With .[a2].Resize(m, 5)
    
36.             .Value = brr
    
37.             .Borders.LineStyle = 1
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.         End With
    
41.     End With
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
44. End Sub
    

复制代码

limonet

关键字：union all

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Sht As Worksheet
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name Like "[1-9]*" Then
            StrSQL = StrSQL & " Union all Select *,'" & Left(Sht.Name, 1) & "' as F0 From [" & Sht.Name & "$A5:D]"
            If Sht.Name Like "*负债*" Then StrSQL = StrSQL & " Union all Select *,'" & Left(Sht.Name, 1) & "' as F0 From [" & Sht.Name & "$E5:H]"
        End If
    Next Sht
    StrSQL = "Select F0,F1,F3 From (" & Mid(StrSQL, 12) & ") Where F1 in('    流动资产合计','    流动负债合计','一、营业收入','四、净利润（净亏损以“-”号填列）')"
    StrSQL = "TransForm First(F3) Select F0 From (" & StrSQL & ") Group By F0 Pivot F1"
    Range("H2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

baofa2

两帖合供参考.zip (65.17 KB, 下载次数: 12)

2024-4-30 17:12 上传

点击文件名下载附件

1. Sub test1() '纯练习，结合上帖，来个一步到位，仅供测试参考
   
2.   
   
3.   Dim s As String, strPath As String, strFile As String
   
4.   Dim Conn As Object, rs As Object, dict(1) As Object
   
5.   Dim data, results(), wks As Worksheet, ran As Range, target As Range, item_
   
6.   Dim strConn As String, strSQL As String, subSQL() As String, strFields As String, strTable As String
   
7.   Dim i As Long, j As Long, x As Long, y As Long, cnt As Long, idx As Long
   
8.   
   
9.   DoApp False
   
10.   
    
11.   For Each wks In Worksheets
    
12.     If wks.Index > 1 Then wks.Delete
    
13.   Next
    
14.   
    
15.   For j = LBound(dict) To UBound(dict)
    
16.     Set dict(j) = CreateObject("Scripting.Dictionary")
    
17.   Next
    
18.   Set Conn = CreateObject("ADODB.Connection")
    
19.   'Set rs = CreateObject("ADODB.Recordset")
    
20.   
    
21.   s = "Excel 12.0;IMEX=1;HDR=YES;Database="
    
22.   If Application.Version < 12 Or InStr(Application.Path, "WPS") > 0 Then
    
23.     s = Replace(s, "12.0", "8.0")
    
24.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
25.   Else
    
26.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
27.   End If
    
28.   
    
29.   strPath = ThisWorkbook.Path & Application.PathSeparator
    
30.   strFile = Dir(strPath & "*.xls*")
    
31.   While Len(strFile)
    
32.     If strPath & strFile <> ThisWorkbook.FullName Then
    
33.       cnt = cnt + 1
    
34.       If cnt = 1 Then
    
35.         With Workbooks.Open(strPath & strFile, 0)
    
36.           For Each wks In .Worksheets
    
37.             wks.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    
38.           Next
    
39.           .Close False
    
40.         End With
    
41.       End If
    
42.       If Conn.State <> 1 Then Conn.Open strConn & strPath & strFile
    
43.       strSQL = strSQL & " UNION ALL SELECT [.strFields.] FROM [" & s & strPath & strFile & "].[[.strTable.]]"
    
44.       If cnt = 49 Then
    
45.         idx = idx + 1
    
46.         ReDim Preserve subSQL(1 To idx)
    
47.         subSQL(idx) = Mid(strSQL, 12)
    
48.         strSQL = vbNullString
    
49.         cnt = 0
    
50.       End If
    
51.     End If
    
52.     strFile = Dir
    
53.   Wend
    
54.   If cnt > 0 Then
    
55.     idx = idx + 1
    
56.     ReDim Preserve subSQL(1 To idx)
    
57.     subSQL(idx) = Mid(strSQL, 12)
    
58.     cnt = 0
    
59.   End If
    
60.   
    
61.   For Each wks In Worksheets
    
62.     With wks
    
63.       If .Index > 1 Then
    
64.         y = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row        '.Cells(.Rows.Count, target.Column).End(xlUp).Row
    
65.         x = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column  ' target.End(xlToRight).Column
    
66.         'Set Target = .Range("A4")
    
67.         Set target = .UsedRange.Find("*编制单位*", , xlValues, , xlByRows, xlPrevious).Offset(1)
    
68.         Set ran = .Range(target, .Cells(y, x))
    
69.         
    
70.         For Each item_ In ran     '若有公式 记录公式
    
71.           If item_.HasFormula Then dict(1).Add item_.Address(0, 0), item_.FormulaR1C1
    
72.         Next
    
73.         
    
74.         data = ran.Value
    
75.         ReDim results(1 To UBound(data) - 1, 1 To UBound(data, 2) - 1)
    
76.         For i = 2 To UBound(data)
    
77.           If Len(data(i, 1)) Then s = data(i, 1) Else s = "NULL"
    
78.           dict(0).Add s & "|" & CStr(i - 2), i - 1
    
79.         Next
    
80.         y = UBound(data) - 1
    
81.         
    
82.         strTable = .Name & "$" & ran.Address(0, 0)
    
83.         strFields = "`" & data(1, 1) & "`"
    
84.         For j = 2 To UBound(data, 2)
    
85.           If data(1, j) Like "*行*次*" Then
    
86.             s = ",NULL"
    
87.             For i = 1 To UBound(results)
    
88.               results(i, j - 1) = data(i + 1, j)
    
89.             Next
    
90.           Else
    
91.             s = ",`" & data(1, j) & "`"
    
92.           End If
    
93.           strFields = strFields & s
    
94.         Next
    
95.         
    
96.         For idx = LBound(subSQL) To UBound(subSQL)
    
97.           strSQL = Replace(Replace(subSQL(idx), "[.strFields.]", strFields), "[.strTable.]", strTable)
    
98.           Set rs = Conn.Execute(strSQL)
    
99.           data = rs.GetRows
    
100.           For x = 0 To UBound(data, 2)
     
101.             If Not IsNull(data(0, x)) Then s = data(0, x) & "|" & (x Mod y) Else s = "NULL" & "|" & (x Mod y)
     
102.             If dict(0).Exists(s) Then
     
103.               i = dict(0)(s)
     
104.               For j = 1 To UBound(data)
     
105.                 If Not IsNull(data(j, x)) Then
     
106.                   If Val(Replace(data(j, x), ",", "")) Then
     
107.                     results(i, j) = Val(results(i, j)) + Val(Replace(data(j, x), ",", ""))
     
108.                   Else
     
109.                     If IsEmpty(results(i, j)) Then results(i, j) = data(j, x)
     
110.                   End If
     
111.                 End If
     
112.               Next
     
113.             End If
     
114.           Next
     
115.         Next
     
116.         target.Offset(1, 1).Resize(UBound(results), UBound(results, 2)) = results
     
117.         
     
118.         If dict(1).Count Then
     
119.           For Each item_ In dict(1).Keys   '若有公式 回写公式
     
120.             .Range(item_).FormulaR1C1 = dict(1)(item_)
     
121.           Next
     
122.         End If
     
123.         
     
124.         cnt = cnt + 1
     
125.         Application.StatusBar = String(88, Chr(32)) & "完成 " & cnt & " / " & Worksheets.Count & " ，已处理： " & .Name
     
126.         
     
127.       End If
     
128.     End With
     
129.    
     
130.     For j = LBound(dict) To UBound(dict)
     
131.       dict(j).RemoveAll
     
132.     Next
     
133.   Next
     
134.   
     
135.   rs.Close
     
136.   Set rs = Nothing
     
137.   Conn.Close
     
138.   Set Conn = Nothing
     
139.   Set target = Nothing
     
140.   Set ran = Nothing
     
141.   For j = LBound(dict) To UBound(dict)
     
142.     Set dict(j) = Nothing
     
143.   Next
     
144.   
     
145.   Worksheets(1).Activate
     
146.   DoApp
     
147. End Sub
     
148. 
     
149. Function DoApp(Optional b As Boolean = True)
     
150.   With Application
     
151.     .ScreenUpdating = b
     
152.     .DisplayAlerts = b
     
153.     .Calculation = -b * 30 - 4135
     
154.     If b Then .StatusBar = vbNullString: Beep
     
155.   End With
     
156. End Function

复制代码