求大神指教多表格提取信息

5550381

使用两个表格内容提取出所需要的，这个需要怎么编写

swl4561255

参见附件。

limonet

关键字：intersect+ where * in

limonet

Sub limont()
    Dim Arr As Variant, i%, Cn As Object, StrSQL$
    i = Application.Match("周" & Mid([F5], 3), Sheet3.Range("A:A"), 0)
    Arr = Intersect(Sheet3.UsedRange, Sheet3.Range(Sheet3.Cells(i, 2), Sheet3.Cells(i, 19)))
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select * From [客户信息$] Where 所属路线 in('" & Replace(RTrim(Join(Application.Transpose(Application.Transpose(Arr)))), " ", "','") & "')"
    Range("B8").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

5550381

limonet 发表于 2024-4-3 11:11
关键字：intersect+ where * in

调试不过，数据异常

limonet

5550381 发表于 2024-4-3 11:17
调试不过，数据异常

不保证WPS能运行，因为大部分没有装ACCESS库，或用2楼大佬的。

5550381

swl4561255 发表于 2024-4-3 10:42
参见附件。

大佬这个如果用VBA来实现的话，这个要怎么编写。

swl4561255

1. Sub test()
   
2. On Error Resume Next
   
3. ar = Sheets("路线表").[A1].End(4).Row
   
4. arr = Sheets("路线表").Range("A2:N" & ar)
   
5. br = Sheets("客户信息").[A1].End(4).Row
   
6. brr = Sheets("客户信息").Range("A2:G" & br)
   
7. Range("B8:H1000").ClearContents
   
8. Dim crr()
   
9. For i = 1 To ar - 1
   
10.    If Right([F5], 1) = Right(arr(i, 1), 1) Then
    
11.       For j = 1 To br - 1
    
12.           For k = 2 To 14
    
13.               If brr(j, 7) = arr(i, k) Then
    
14.                   m = m + 1
    
15.                   ReDim Preserve crr(1 To 7, 1 To m)
    
16.                      For l = 1 To 7
    
17.                          crr(l, m) = brr(j, l)
    
18.                      Next
    
19.                End If
    
20.            Next
    
21.        Next
    
22.     End If
    
23. Next
    
24. [B8].Resize(m, 7) = Application.Transpose(crr)
    
25. End Sub

复制代码