The sheets must be named "Sheet1" and "Sheet2" or the code needs to be changed to what they are.
Sub Webber(): Dim Cust As String, w2 As Worksheet, w1 As Worksheet
Dim r As Long, N As Long, i, J, Z
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
With CreateObject("Scripting.Dictionary")
For r = 3 To w2.Range("A" & Rows.Count).End(xlUp).row: Cust = w2.Range("A" & r)
If Cust <> "" Then
If .Item(Cust) = "" Then
.Item(Cust) = w2.Range("E" & r) & "~" & w2.Range("G" & r)
Else:
.Item(Cust) = .Item(Cust) & "|" & w2.Range("E" & r) & "~" & w2.Range("G" & r)
: End If: End If
i = .Item(Cust): Next r
r = 16: Do Until Cust = "": Cust = Range("A" & r)
If .Exists(Cust) Then
J = w1.Range("D" & r) & "~" & w1.Range("E" & r)
i = .Item(Cust): Z = Split(i, "|")
For N = 0 To UBound(Z)
If Z(N) <> J Then
w1.Range("A" & r + 1).EntireRow.Insert
w1.Range("D" & r + 1).Resize(1, 2) = Split(Z(N), "~"): r = r + 1
End If: Next N: End If: r = r + 1: Loop
End With
End Sub
Directions for running the routine(s) just supplied
If you haven't used macros before you'll need to go to:
File- options - trust center -trust center settings - macro settings ,
the second option down (disable all macros with notification)
Then - Copy the code to the clipboard
Open your Workbook
Press ALT + F11 to open the Visual Basic Editor.
Select "Module" from the Insert menu
Type "Option Explicit" then paste the code under it
With the cursor between Sub and End Sub press F5 (F8 to Single Step)
OR
Press ALT + Q to close the code window.
Press ALT + F8 then double click on the macro name
Bookmarks