Index Multiple Values into a Single Cell-CodePudding

I am trying to get stock qty from Sheet(SOH), then update them to Sheet(Report) soh column. However, I am having a issue to index Multiple Values into a Single Cell. I am using a "Application.Index" code as below, any help would be greatly appreciated!

Sub Fillstock_Test()

'Get qty, from SOH to Report'

Dim i, lr, sold As Long
Dim soh As Variant
Dim sku, soh_str As String

lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    sku = Sheets("Report").Cells(i, "B").Value
    soh = Application.IfError(Application.Index(Sheets("SOH").Range("A:Z"), _
        Application.Match(sku, Sheets("SOH").Range("A:A"), 0), 2), 0)
    soh_str = ": " & soh  'Get SOH String


    Sheets("Report").Cells(i, "C").Value = soh_str

Next i

End Sub

Sheet("Report" &"SOH")

CodePudding user response：

A VBA Lookup: Match Delimited Cell Values

Sub Fillstock_Test()

    'Get qty, from SOH to Report'
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("SOH")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    Dim srgSKU As Range: Set srgSKU = sws.Range("A2", sws.Cells(slRow, "A"))
    Dim srgQTY As Range: Set srgQTY = srgSKU.EntireRow.Columns("B")
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Report")
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row
    Dim drgSKU As Range: Set drgSKU = dws.Range("B2", dws.Cells(dlRow, "B"))
    Dim drgQTY As Range: Set drgQTY = drgSKU.EntireRow.Columns("C")
    
    ' Source
    Dim srIndex As Variant ' to read from srgQTY
    Dim sQTY As String
    ' Destination
    Dim dCell As Range
    Dim dSkuQty() As String ' read SKU, write QTY string
    Dim dSKU As String
    Dim dQTY As String
    Dim drIndex As Long
    Dim ds As Long
       
    For Each dCell In drgSKU.Cells
        drIndex = drIndex   1 ' to write to drgQTY
        ' Split: replace SKU with matched QTY.
        dSkuQty = Split(CStr(dCell.Value), vbLf)
        For ds = 0 To UBound(dSkuQty)
            dSKU = dSkuQty(ds)
            If Len(dSKU) > 0 Then ' is not blank
                srIndex = Application.Match(dSKU, srgSKU, 0)
                If IsNumeric(srIndex) Then ' is found
                    sQTY = CStr(srgQTY.Cells(srIndex).Value)
                    dSkuQty(ds) = ":" & sQTY
                Else ' ('If IsError(srIndex) Then') ' is not found
                    dSkuQty(ds) = "sku not found" ' adjust!
                End If
            Else ' is blank
                dSkuQty(ds) = "sku is blank" ' adjust!
            End If
        Next ds
        ' Join.
        dQTY = Join(dSkuQty, vbLf)
        ' Write.
        drgQTY.Cells(drIndex).Value = dQTY
    Next dCell

End Sub

CodePudding user response：

You can loop the range and append the data to string value dividing by &Chr(10)& for example

For j=1 to Sheets("Report").UsedRamge.Rows.Count

For i=1 To ActiveSheet.UsedRamge.Rows.Count
If Instr(1,Sheets("Report").Cells(j,1),Sheets("SOH").Cells(1,i) then 
Sheets("Report").Cells(j,1)=Sheets("Report").Cells(j,1)&Chr(10)&Application.Match(Sheets("SOH").Cells(1,i),Sheets("SOH").Columns(2),0)
Next i

Next j

something like that

CodePudding user response：

If you don't mind formulae:

In C2:

=BYROW(B2:B5,LAMBDA(a,TEXTJOIN(CHAR(10),,XLOOKUP(TEXTSPLIT(a,CHAR(10)),B7:B11,":"&C7:C11,"Not Found"))))