遍历所有工作表提取相应的数据到Sheet1

kort20034

尝试了好久，不是报错就是运行没反应，提及遍历工作表的参考帖子也好少，求帮忙，万分感谢！

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;Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "Sheet1" Then
            StrSQL = StrSQL & " Union All Select '" & Sht.Name & "' as Sht,Sum(" & Range("A1") & ") From [" & Sht.Name & "$A:F]"
        End If
    Next Sht
    Range("A8").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

kort20034

limonet 发表于 2024-6-25 22:25
关键字：union all

这不是调数据库用的吗？还可以用这样来实现，受教，好好查询研究一下，十分感谢！

shiruiqiang

peteryhr

这种情况最适合sql语句。学习了

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.26
   
2.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
3.     st = sh.[a1].Value
   
4.     ReDim brr(1 To 1000, 1 To 2)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             arr = sht.UsedRange
   
8.             m = m + 1
   
9.             For j = 1 To UBound(arr, 2)
   
10.                 If arr(1, j) = st Then
    
11.                     Sum = 0
    
12.                     For i = 2 To UBound(arr)
    
13.                         Sum = Sum + arr(i, j)
    
14.                     Next
    
15.                     brr(m, 1) = sht.Name
    
16.                     brr(m, 2) = Sum
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         .[a2].Resize(1000, 2) = ""
    
23.         .[a2].Resize(m, 2) = brr
    
24.     End With
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

kort20034

shiruiqiang 发表于 2024-6-26 07:19

谢谢，另外BEEP代码是干啥的？

kort20034

ykcbf1100 发表于 2024-6-26 09:34
参与一下。。。

谢谢！学习了