根据A列条件，在品项对照表找出条件条件值 ，并列到黄色区域

无声地拥抱

求写

根据A列条件，在品项对照表找出条件条件值 ，并列到黄色区域





Sub sql()
    Dim sql As String
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    sql = "select b.对应产品名称值 from [结果$A2:A65536] a inner join [品项对照$] b on a.品项 = b.品项 "
    Sheets("结果").Range("B3").CopyFromRecordset conn.Execute(sql)
   
End Sub


如何转置查询出来 的结果写入对应的值
以上语句如何修改

无声地拥抱

谁能解决，求助
是哪里表达错误 吗，请告知

shiruiqiang

无声地拥抱

shiruiqiang 发表于 2024-10-22 21:50

结果 没达到黄色区域内容，可以用SQL吗，

无声地拥抱

有其他人可以帮忙 吗，求助

无声地拥抱

求关注 ，着急

Qs18

1. Sub sql()
   
2.     Dim sql As String, i
   
3.     Set conn = CreateObject("ADODB.Connection")
   
4.     Set rst = CreateObject("ADODB.Recordset"): Set dic = CreateObject("scripting.dictionary")
   
5.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
   
6.     sql = "select a.品项,b.对应产品名称值 from [结果$A2:A65536] a inner join [品项对照$] b on a.品项 = b.品项 "
   
7.     rst.Open sql, conn, 1, 3
   
8.     arr = Application.Transpose(rst.GetRows)
   
9.     ReDim brr(1 To UBound(arr), 1 To 10)
   
10.     For i = 1 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.     If Not dic.exists(s) Then
    
13.         m = m + 1
    
14.         dic(arr(i, 1)) = m
    
15.         brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2)
    
16.     Else
    
17.             r = dic(arr(i, 1))
    
18.             For j = 2 To 10
    
19.                 If brr(r, j) = "" Then brr(r, j) = arr(i, 2): Exit For
    
20.             Next
    
21.     End If
    
22.     Next i
    
23.     With Sheets("结果")
    
24.         .Range("a3").Resize(m, UBound(brr)) = brr
    
25.     End With
    
26.        rst.Close: conn.Close: Set rst = Nothing: Set conn = Nothing
    
27. End Sub

复制代码

Qs18

试试...........

Qs18

试试.......

MR_PP

Qs18 发表于 2024-10-23 12:59
试试.......

膜拜大佬。