根据单元格药品名称查找药品入库明细中全部发票号与数量

业务员

上图红色字体是药品信息，以此去入库信息工作表检索药品对应的发票号和数量

上图红色信息是需要引用的信息

我的需求，查询结果如下图



药品信息，入库信息都是很多的，同一个药品可以有发票七八张，我上传少量数据供老师们测试。

3822

测试看看呢！

业务员

3822 发表于 2023-7-12 16:17
测试看看呢！

这么简单啊，我试试哈。谢啦，感觉还不错，我自己吧i从2到100，100不够智能，用vba改成了最后一行

limonet

用到SQL、getrows，split、join

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, i%, Arr As Variant
    Set Cn = CreateObject("adodb.connection")
    Cn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    StrSQL = "select 名称,发票号&'@'&数量 as result from [入库信息$] order by 名称"
    StrSQL = "select result from (" & StrSQL & ") where 名称='"
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cn.Execute(StrSQL & Cells(i, "B").Value & "'").getrows))
        Cells(i, "R").Resize(1, UBound(Arr) * 2) = Split(Join(Arr, "@"), "@")
    Next i
End Sub

半百

字典，请测试

3190496160

Sub 匹配()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("入库信息")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:h" & r)
End With
For i = 2 To UBound(ar)
     If Trim(ar(i, 4)) <> "" Then
        If Not d.exists(Trim(ar(i, 4))) Then
            d(Trim(ar(i, 4))) = ar(i, 3)
        Else
            d(Trim(ar(i, 4))) = d(Trim(ar(i, 4))) & "|" & ar(i, 3)
        End If
    End If
Next i
With Sheets("合同量内表")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    .[a1].CurrentRegion.Offset(1, 17) = Empty
    br = .Range("b1:b" & rs)
    For i = 2 To UBound(br)
        y = 17
         If Trim(br(i, 1)) <> "" Then
            If d.exists(Trim(br(i, 1))) Then
                zd = d(Trim(br(i, 1)))
                If InStr(zd, "|") = 0 Then
                    .Cells(i, 18) = zd
                Else
                    rr = Split(zd, "|")
                    For s = 0 To UBound(rr)
                        y = y + 1
                        .Cells(i, y) = rr(s)
                    Next s
                End If
            End If
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

发票查找测试.rar (17.5 KB, 下载次数: 15)

2023-7-12 16:29 上传

点击文件名下载附件

业务员

3822 发表于 2023-7-12 16:17
测试看看呢！

觉得真是巧妙，又实用又好理解