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

jpylxj

ykcbf1100 发表于 2024-4-7 15:46
参与一下。。。

感谢，已完美实现，但有一个新的需求，工作簿2中增加一个C列备注列，但C列值为空时提取数据，不为空时不提取数据，能否解决。

ykcbf1100

jpylxj 发表于 2024-4-7 16:26
感谢，已完美实现，但有一个新的需求，工作簿2中增加一个C列备注列，但C列值为空时提取数据，不为空时不 ...

上附件吧，应该不难

ykcbf1100

jpylxj 发表于 2024-4-7 16:26
感谢，已完美实现，但有一个新的需求，工作簿2中增加一个C列备注列，但C列值为空时提取数据，不为空时不 ...

看到新附件了，代码中加一个判断就可以了。

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 arr(i, 3) = Empty Then
    
15.             If Not d.exists(s) Then
    
16.                 d(s) = arr(i, 2)
    
17.             Else
    
18.                 d(s) = IIf(InStr(d(s), arr(i, 2)), d(s), d(s) & "、" & arr(i, 2))
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With sh
    
23.         r = .Cells(Rows.Count, 1).End(3).Row
    
24.         zrr = .[a1].Resize(r, 2)
    
25.         For i = 2 To UBound(zrr)
    
26.             s = zrr(i, 1)
    
27.             If d.exists(s) Then
    
28.                 zrr(i, 2) = d(s)
    
29.             End If
    
30.         Next
    
31.         .[a1].Resize(r, 2) = zrr
    
32.         .[a1].Resize(1, 2).Interior.Color = 49407
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    
38. 
    

复制代码

yellowhawk

能用公式的，不要用VBA=SUM(([2.xlsx]Sheet1!$A$2:$A$19=A6)*([2.xlsx]Sheet1!$B$2:$B$19))

shiruiqiang

学习并根据limonet和baofa22位老师的代码，学习sql子嵌套和数组的写法

baofa2

jpylxj 发表于 2024-4-7 14:54
非常感谢你的分享，想在工作簿2里加一个条件，当C列空白时进行合并，OK时不合并，有没有解决方法。