以分隔格式获取结果

Question

我正在尝试设置一个电子表格，当输入 PackNum 时，该 PackNum 的所有报价都将以分隔格式放入报价单元格中。

例如：
我在电子表格中输入 Packnumber 600035
我想要在 B 列中划定的所有优惠

来源：

我想要的结果

我想使用

Findfirst

，但意识到它只会给我第一个结果，而不是我想要的格式。

Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim UpsellWB As Excel.Workbook
    Dim Deletes As Excel.Worksheet
    Dim lrow As Long
    Dim db As DAO.Database
    Dim UpsellData As DAO.Recordset
    
    ' The variable KeyCells contains the cells that will
    Set KeyCells = Range("A2:A500")
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing And Range("A2").Value > 100 Then
    'When cell changes run program
        
        'Recordsets
        Set db = DBEngine.OpenDatabase("<datapool path>\db.accdb")
        Set UpsellData = db.OpenRecordset("UpsellDeletePool")
        'Workbooks
        Set UpsellWB = Workbooks.Open("<spreadsheet path>\Upsell.xlsm")
        'Worksheets
        Set Deletes = UpsellWB.Worksheets("Deletes")
        'set lrow
        lrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'With Deletes
    'For I = 2 To lrow
    'UpsellData.FindFirst ("[Packnum]= '" & Deletes.Range("A" & I).Value & "'")
    '        Deletes.Range("B" & I).Value = UpsellData.Fields("[Offer]").Value
    'Next I
    'End With
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Else
    
    End If
    
    'Closing Procedure
    Set db = Nothing
    Set UpsellData = Nothing
    Set UpsellWB = Nothing
    Set Deletes = Nothing
End Sub

数据：
我一直在考虑两种选择。
一种选择是使用 Access 数据库中的查询作为记录集来提取数据。
另一个选项是，我将相同的记录集设置作为名为“DeletePool”的工作表上的表，每次打开工作簿时都会更新。

Answer 1

如果数据位于 Excel 工作表上，则可以使用 Excel 公式实现这一点。

单元格 H1 中的公式

=TEXTJOIN(",",TRUE,FILTER(B2:B15,(A2:A15=F1)*(C2:C15=F2)))

旁注：我不知道为什么这个问题被标记为

Access

Answer 2

VBA

的替代方案是使用

ADO

和

SQL

。

该代码使用 SQL 查询，使用单元格

pack number

中的

L2

和单元格

year

中的

N2

作为输入参数。逗号分隔的输出位于单元格

M2

中

添加参考文献：

• Microsoft ActiveX 数据对象 6.1 库
• Microsoft ActiveX 数据对象记录集 6.0 库

Sub Test()
    Dim objADO As ADODB.Connection, objRS As ADODB.Recordset
    Dim strFile As String, strSQL As String, myArr As Variant
    
    Set objADO = New ADODB.Connection
    Set objRS = New ADODB.Recordset
    
    strFile = ThisWorkbook.FullName
    
    With objADO
        If Val(Application.Version) < 14 Then
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties") = "Excel 8.0; HDR=Yes;IMEX=1;"
        Else
            .Provider = "Microsoft.Ace.OLEDB.12.0"
            .Properties("Extended Properties") = "Excel 12.0; HDR=Yes;IMEX=1;"
        End If
        .Mode = adModeRead
        .Properties("User ID") = "Admin"
        .ConnectionString = strFile
        .Open
    End With
        
    strSQL = "Select [offer] From [Sheet1$] Where [packnum]=" & Range("L2") & " And [mailyear]= " & Range("N2") & " And [packnum] Is Not Null"
    
    With objRS
       .CursorType = adOpenStatic
       .CursorLocation = adUseClient
       .LockType = adLockBatchOptimistic
       .ActiveConnection = objADO
       .Source = strSQL
       .Open
    End With
    
    myArr = objRS.GetRows(, , "offer")
    Range("M2") = Join(Application.Index(myArr, 0), ", ")
    
    objRS.Close
    
    If objRS.State = adStateOpen Then objRS.Close
    If objADO.State = adStateOpen Then objADO.Close
    
    Set objRS = Nothing
    Set objADO = Nothing
End Sub

.