The revolutionary project management tool is here! Plan visually with a single glance and make sure your projects get done.
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
MsgBox "Data not found!", vbCritical
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)).PasteSpecial operation:=xlAdd
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
sws.Range("K" & i + 1).Resize(1, UBound(z, 1) + 1).Value = z
If UBound(z, 1) >= 0 Then
sws.Range("K" & i + 1).Resize(1, UBound(z, 1) + 1).Value = z
End If
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
MsgBox "Data not found!", vbCritical
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)).PasteSpecial operation:=xlAdd
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