用VBA读取另一工作簿符合条件的数据

jpylxj

以工作簿1的A列为条件读取工作簿2中B列的数据，将其合并后按条件放在工作簿1中的对应的B列单元格中。合并后例子：100、150、200.

limonet

关键字：group by+left join

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select 项目一,Sum(类型) as 类型 From [Excel 12.0;DataBase=" & ThisWorkbook.Path & "\2.xlsx].[Sheet1$] Group By 项目一"
    StrSQL = "Select 类型 From [Sheet1$A:A]a Left join (" & StrSQL & ")b On a.项目一=b.项目一"
    Range("B2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

baofa2

新建文件夹.zip (31.71 KB, 下载次数: 12)

2024-4-7 11:58 上传

点击文件名下载附件

jpylxj

limonet 发表于 2024-4-7 11:33
Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")

非常感谢，是把相同条件的数据合并在一个单元格，不需要求得。

jpylxj

limonet 发表于 2024-4-7 11:32
关键字：group by+left join

非常感谢，是合并在一个单元格，不需要求和

jpylxj

limonet 发表于 2024-4-7 11:33
Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")

是把相同条件的数据组合在一个单元格里，不需要求和。

jpylxj

baofa2 发表于 2024-4-7 11:58

非常感谢你的分享，想在工作簿2里加一个条件，当C列空白时进行合并，OK时不合并，有没有解决方法。

ykcbf1100

附件供参考，字典

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.4.7
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     f = p & "\2.xlsx"
   
7.     Set wb = Workbooks.Open(f, 0)
   
8.     With wb.Sheets(1)
   
9.         arr = .UsedRange
   
10.         wb.Close False
    
11.     End With
    
12.     For i = 2 To UBound(arr)
    
13.         s = arr(i, 1)
    
14.         If Not d.exists(s) Then
    
15.             d(s) = arr(i, 2)
    
16.         Else
    
17.             d(s) = IIf(InStr(d(s), arr(i, 2)), d(s), d(s) & "、" & arr(i, 2))
    
18.         End If
    
19.     Next
    
20.     With sh
    
21.         r = .Cells(Rows.Count, 1).End(3).Row
    
22.         zrr = .[a1].Resize(r, 2)
    
23.         For i = 2 To UBound(zrr)
    
24.             s = zrr(i, 1)
    
25.             If d.exists(s) Then
    
26.                 zrr(i, 2) = d(s)
    
27.             End If
    
28.         Next
    
29.         .[a1].Resize(r, 2) = zrr
    
30.         .[a1].Resize(1, 2).Interior.Color = 49407
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码