Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
Solved

# Excel formula lookup multiple charges

Posted on 2016-08-17
Medium Priority
90 Views
I have two spread sheets, one with shipments and another with the charges associated with the shipments.
There are multiple charges to each shipment.

I need to combine - pulling the multiple charges into the same row as the shipment.
Challenges - I don't know how many shipments there will be or how many charges - or how many charges for each shipment.

I attached a sample, in case that helps.
EXAMPLE-LOOKUP.xlsx
0
Question by:Euro5
[X]
###### Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points
• 6
• 4

LVL 27

Expert Comment

ID: 41759356
the question is not clear to me,  what the end result should look like? is it shown in the sheet called "Sample of final"?
0

Author Comment

ID: 41759426
Sorry, yes, the final should look like that. The information is compiled from the two other sheets.
I need a formula in the shipments sheet to pull the charges into it.
0

LVL 32

Accepted Solution

Subodh Tiwari (Neeraj) earned 2000 total points
ID: 41759432

In the attached, on Shipments Sheet, click the button "Combine Data" to get the desired output.

``````Sub CombineShipmentCharges()
Dim sws As Worksheet, cws As Worksheet
Dim x, y, z, dict
Dim i As Long, j As Long, slr As Long, clr As Long, slc As Long
Dim str
Set sws = Sheets("Shipments")
Set cws = Sheets("Charges")
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
clr = cws.Cells(Rows.Count, 1).End(xlUp).Row
slc = sws.Cells(1, Columns.Count).End(xlToLeft).Column
If slr < 2 Or clr < 2 Then
Exit Sub
End If
If slc > 10 Then sws.Range("K1", sws.Cells(slr, slc)).Clear
Set dict = CreateObject("Scripting.Dictionary")
x = sws.Range("A2:A" & slr).Value
y = cws.Range("A1").CurrentRegion.Value

For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i

For i = 2 To UBound(y, 1)
If dict.Item(y(i, 1)) = "" Then
dict.Item(y(i, 1)) = y(i, 10) & ";" & y(i, 11)
Else
dict.Item(y(i, 1)) = dict.Item(y(i, 1)) & ";" & y(i, 10) & ";" & y(i, 11)
End If
Next i

For i = 1 To UBound(x, 1)
z = Split(dict.Item(x(i, 1)), ";")
sws.Range("K" & i + 1).Resize(1, UBound(z, 1) + 1).Value = z
Next i

slc = sws.UsedRange.Columns.Count
sws.Range("A" & slr + 1).Copy
sws.Range("K2", sws.Cells(slr, slc)).NumberFormat = "#0.00"
sws.Range("K1:L1").Value = Array("Surcharge desc 1", "Surcharge Amount 1")
sws.Range("K1:L1").AutoFill sws.Range("K1", sws.Cells(1, slc)), xlFillDefault
sws.Columns.AutoFit
Set dict = Nothing
End Sub
``````
EXAMPLE-LOOKUP.xlsm
0

Author Closing Comment

ID: 41759462
Excellent - thanks so much!!
0

Author Comment

ID: 41759470
Subodh Tiwari (Neeraj), if there are no charges associated with the shipping, I get an error on this line. Can we just have it move on if there are no associated charges?

``````   sws.Range("K" & i + 1).Resize(1, UBound(z, 1) + 1).Value = z
``````
0

Author Comment

ID: 41759477
ALSO, I always starts on column K. I don't know how many columns will be in the shipping report. Can it start the first empty column?
0

LVL 32

Expert Comment

ID: 41759491
Replace existing line#34 with the following....

``````   If UBound(z, 1) >= 0 Then
sws.Range("K" & i + 1).Resize(1, UBound(z, 1) + 1).Value = z
End If
``````

See if that resolves your issue.
0

Author Comment

ID: 41759516
Yes - that eliminated the error - thanks!!
0

LVL 32

Expert Comment

ID: 41759528
Replace the previous code with the following one.
The tweaked code will place the data dynamically on Shipments sheet.

``````Sub CombineShipmentCharges()
Dim sws As Worksheet, cws As Worksheet
Dim x, y, z, dict
Dim i As Long, j As Long, slr As Long, clr As Long, slc As Long, nslc As Long
Dim str
Set sws = Sheets("Shipments")
Set cws = Sheets("Charges")
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
clr = cws.Cells(Rows.Count, 1).End(xlUp).Row
slc = sws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If slr < 2 Or clr < 2 Then
Exit Sub
End If
Set dict = CreateObject("Scripting.Dictionary")
x = sws.Range("A2:A" & slr).Value
y = cws.Range("A1").CurrentRegion.Value

For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i

For i = 2 To UBound(y, 1)
If dict.Item(y(i, 1)) = "" Then
dict.Item(y(i, 1)) = y(i, 10) & ";" & y(i, 11)
Else
dict.Item(y(i, 1)) = dict.Item(y(i, 1)) & ";" & y(i, 10) & ";" & y(i, 11)
End If
Next i

For i = 1 To UBound(x, 1)
z = Split(dict.Item(x(i, 1)), ";")
If UBound(z, 1) >= 0 Then
sws.Cells(i + 1, slc).Resize(1, UBound(z, 1) + 1).Value = z
End If
Next i

nslc = sws.UsedRange.Columns.Count
sws.Range("A" & slr + 1).Copy
sws.Range(sws.Cells(2, slc), sws.Cells(slr, nslc)).NumberFormat = "#0.00"
sws.Range(sws.Cells(1, slc), sws.Cells(1, nslc)).Value = Array("Surcharge desc 1", "Surcharge Amount 1")
sws.Range(sws.Cells(1, slc), sws.Cells(1, slc + 1)).AutoFill sws.Range(sws.Cells(1, slc), sws.Cells(1, nslc)), xlFillDefault
sws.Columns.AutoFit
Set dict = Nothing
End Sub
``````
0

Author Comment

ID: 41759552
PERFECT!  Thanks so much!
0

LVL 32

Expert Comment

ID: 41759556
You're welcome.
0

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

My attempt to use PowerShell and other great resources found online to simplify the deployment of Office 365 ProPlus client components to any workstation that needs it, regardless of existing Office components that may be needing attention.
Ever wonder what it's like to get hit by ransomware? "Tom" gives you all the dirty details first-hand â€“ and conveys the hard lessons his company learned in the aftermath.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a qâ€¦
###### Suggested Courses
Course of the Month5 days, 7 hours left to enroll