Macro for delimited data

[swarmo]

Hi all,

I am absolutely stumped on how to solve this challenge with a macro.

I have software providing me with multiple rows of data, with all the data relating to a particular job placed in a single cell, separated by a semi-colon.
An example is below.

1 x Primsal 7w B22WWB (outdoor);3 x Ecobulb 12w Outdoor Reflector (outdoor);2 x Primsal 7w E27WWB (outdoor);3 x Ecobulb 8w Indoor Reflector (allbr);2 x Ecomatters E14 Candle (allbr);6 x Primsal 7w E27WWB (lounge);5 x Primsal 7w B22WWB (lounge);4 x Primsal 7w B22WWB (allbr);3 x Primsal 7w E27WWB (allbr);2 x Ecobulb 8w Indoor Reflector (lounge);1 x Primsal 7w B22WWB (laundry);

<tbody>
</tbody>

I basically need to develop a macro that will count the quantities of each product, relating to that particular job. Often the same product is listed with a different quantity multiple times within the same cell. This is because the same product was installed in a different room in that job.

Products that are possible are as follows.

Primsal 7w B22WWB

Primsal 7w E27WWB

Primsal 7w B22CWB

Primsal 7w E27CWB

Ecomatters E14 Candle

Ecomatters B15 Candle

Ecobulb 8w Indoor Reflector

Ecobulb 12w Outdoor Reflector

Ecomatters-90E2

Ecomatters 5w GU10

<tbody>
</tbody>

The job data cells start at P2 of the spreadsheet and the rows are dependent on the number of jobs listed within the spreadsheet.

Any help or guidance will be greatly appreciated.

Thank you

 

[mohadin]

May be

Sub t2()
    Dim a As Variant
    x = Split(Range("p2"), ";")
    ReDim a(1 To UBound(x))
    For i = 0 To UBound(x) - 1
        a(i + 1) = Trim(Mid(Mid(x(i), WorksheetFunction.Find("x", x(i)) + 1, 255), 1, _
                            Len(Mid(x(i), WorksheetFunction.Find("x", x(i)) + 1, 255)) - Len(Mid(Mid(x(i), _
                             WorksheetFunction.Find("x", x(i)) + 1, 255), WorksheetFunction.Find("(", Mid(x(i), _
                             WorksheetFunction.Find("x", x(i)) + 1, 255)), 255)) - 1))
    Next i
    Range("p2").Offset(, 1).Resize(UBound(a)) = Application.Transpose(a)
End Sub

 

[Paul Ked]

https://1drv.ms/x/s!Av8oW8_xzD3ErEjW4xYWe_tVfF96?e=ohDLyA

Sub GetProducts()
    Dim Prod As Variant, x As Long, i As Long, j As Long, Itm As Variant, Lmp As Variant
    Columns(2).ClearContents
    For x = 2 To Cells(Rows.Count, "P").End(3).Row
        Prod = Split(Cells(x, "P"), ";")
        For i = 0 To UBound(Prod) - 1
            For j = 1 To Cells(Rows.Count, 1).End(3).Row
                Itm = Split(Prod(i), "x")
                Lmp = Split(Itm(1), "(")
                If Mid(Lmp(0), 2, Len(Lmp(0)) - 2) = Cells(j, 1) Then
                    Cells(j, 2) = Cells(j, 2) + CLng(Itm(0))
                End If
            Next
        Next
    Next
End Sub

 

[Paul Ked]

Products in Column A, Qty's in B
Product names in P have to match those in A

 

[swarmo]

Thanks guys.

I have just realised that I need to be able to filter the data to be able to calculate sales commissions and installer commissions for each row.

I also discovered that the job data starts in Q2, not P2.

Are you able to change the coding so that dependent on a list of products, product columns will be made to the right of Q (In case I add or remove products in the future).
Then for each row, the product columns will be populated with the total quantities from the data in Q. This way I can run a simple filter and see how many lamps the sales and installers should be paid for each job.

Thanks again

 

[mohadin]

Sub t2()
    Dim a As Variant
    Dim fun As String
   Dim WF As WorksheetFunction
Set WF = Application.WorksheetFunction
    x = Split(Range("Q2"), ";")
    ReDim a(1 To UBound(x), 1 To 2)
    For i = 0 To UBound(x) - 1
        a(i + 1, 1) = Trim(Mid(Mid(x(i), WF.Find("x", x(i)) + 1, 255), 1, _
                            Len(Mid(x(i), WF.Find("x", x(i)) + 1, 255)) - Len(Mid(Mid(x(i), _
                             WF.Find("x", x(i)) + 1, 255), WF.Find("(", Mid(x(i), _
                             WF.Find("x", x(i)) + 1, 255)), 255)) - 1))
           a(i + 1, 2) = Left(x(i), WF.Find("x", x(i)) - 2)
    Next i
    Range("Q2").Offset(, 1).Resize(UBound(a), 2) = a
End Sub

 

[swarmo]

Thanks Mohadin,

I need some more help.

I have uploaded a link to a sample Data Sheet that I am referencing.
https://www.dropbox.com/s/rhr639ubp0e8ioc/Data Sheet.xlsx?dl=0

It has a sheet named 'Products', where all products will be listed. These product names need to be written to the 'Data Sheet' columns, from R1 onwards.
The code will then go through the data in Q2 and calculate the total quantities and place them in the relevant product columns. Then proceed to do this for the remaining rows.
This way I can create filters for each job, based on sales staff and installers.

Thank you for your help.

 

[Akuini]

Hi, swarmo
Try this:

[FONT=Lucida Console][COLOR=Royalblue]Sub[/COLOR] a1114629a()
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], j [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], n [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] c [COLOR=Royalblue]As[/COLOR] Range
[COLOR=Royalblue]Dim[/COLOR] tx [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] va, vb, vc, ary
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]

Application.ScreenUpdating = False
Sheets([COLOR=Darkcyan]"Data"[/COLOR]).Activate

[COLOR=Royalblue]With[/COLOR] Sheets([COLOR=Darkcyan]"Products"[/COLOR])
    [COLOR=Royalblue]Set[/COLOR] c = .Range([COLOR=Darkcyan]"A1"[/COLOR], .Cells(.Rows.Count, [COLOR=Darkcyan]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
    
    vb = c.Value
    c.Copy
    Range([COLOR=Darkcyan]"R1"[/COLOR]).PasteSpecial Transpose:=True
    
    n = Range([COLOR=Darkcyan]"Q"[/COLOR] & Rows.Count).[COLOR=Royalblue]End[/COLOR](xlUp).Row
    [COLOR=Royalblue]ReDim[/COLOR] va([COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] n - [COLOR=Brown]1[/COLOR], [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](vb, [COLOR=Brown]1[/COLOR]))
    vc = Range([COLOR=Darkcyan]"Q2:Q"[/COLOR] & n).Value
    
    [COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=Darkcyan]"scripting.dictionary"[/COLOR])
    d.CompareMode = vbTextCompare


[COLOR=Royalblue]For[/COLOR] j = [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](vc, [COLOR=Brown]1[/COLOR])

    tx = Replace(vc(j, [COLOR=Brown]1[/COLOR]), [COLOR=Darkcyan]");"[/COLOR], [COLOR=Darkcyan]" x "[/COLOR])
    tx = Replace(tx, [COLOR=Darkcyan]" ("[/COLOR], [COLOR=Darkcyan]" x "[/COLOR])
    ary = Split(tx, [COLOR=Darkcyan]" x "[/COLOR])
    
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](ary) [COLOR=Royalblue]Step[/COLOR] [COLOR=Brown]3[/COLOR]
        d(ary(i)) = d(ary(i)) + [COLOR=Royalblue]CLng[/COLOR](ary(i - [COLOR=Brown]1[/COLOR]))
    [COLOR=Royalblue]Next[/COLOR]
    
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](vb, [COLOR=Brown]1[/COLOR])
        [COLOR=Royalblue]If[/COLOR] d.Exists(vb(i, [COLOR=Brown]1[/COLOR])) [COLOR=Royalblue]Then[/COLOR] va(j, i) = d(vb(i, [COLOR=Brown]1[/COLOR]))
    [COLOR=Royalblue]Next[/COLOR]

    d.RemoveAll
    
[COLOR=Royalblue]Next[/COLOR]

Range([COLOR=Darkcyan]"R2"[/COLOR]).Resize([COLOR=Royalblue]UBound[/COLOR](va, [COLOR=Brown]1[/COLOR]), [COLOR=Royalblue]UBound[/COLOR](va, [COLOR=Brown]2[/COLOR])) = va
Application.ScreenUpdating = True

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

 

[swarmo]

Thank you so much Akuini! Perfect solution.

Much appreciated

 

[Akuini]

You're welcome, glad to help, & thanks for the feedback.