Create a new line for each match instead of concatenate

PGNewbie

New Member
Joined
Feb 6, 2020
Messages
41
Office Version
  1. 365
Platform
  1. Windows
I am using a vba code that compares column "C" on two work books and concatenates the matches found onto one cell. I need to be able to add the first match to the existing row in workbook1 and then create a new row for each match instead of concatenating, copying over columns "B", "C" and "D" from workbook2 on to workbook1, underneath the original row in workbook1.

VBA Code:
Sub PGNewbie()
Dim w1 As Worksheet, w2 As Worksheet
Dim Cl As Range
Application.ScreenUpdating = False

Set w2 = Workbooks("Book2.xlsx").ActiveSheet
Set w1 = Workbooks("Book1.xlsx").ActiveSheet

With CreateObject("scripting.dictionary")
For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
If Not .Exists(Cl.Value) Then
.Add Cl.Value, Cl.Offset(, 1).Value
Else
.Item(Cl.Value) = .Item(Cl.Value) & "," & Cl.Offset(, 1).Value
End If
Next Cl
For Each Cl In w1.Range("C2", w1.Range("C" & Rows.Count).End(xlUp))
If .Exists(Cl.Value) Then Cl.Offset(, 1).Value = .Item(Cl.Value)
Next Cl
End With
End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
How about
VBA Code:
Sub PGNewbie()
   Dim w1 As Worksheet, w2 As Worksheet
   Dim Cl As Range
   Dim i As Long
   Dim Sp As Variant
   Application.ScreenUpdating = False
      
   Set w2 = Workbooks("Book2.xlsx").ActiveSheet
   Set w1 = Workbooks("Book1.xlsx").ActiveSheet
   
   With CreateObject("scripting.dictionary")
      For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
         End If
      Next Cl
      For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
         If .Exists(w1.Cells(i, 3).Value) Then
            Sp = Split(.Item(w1.Cells(i, 3).Value), "|")
            If UBound(Sp) = 0 Then
               w1.Cells(i, 4).Value = Sp(0)
            Else
               w1.Rows(i + 1).Resize(UBound(Sp)).Insert
               w1.Rows(i).Resize(UBound(Sp) + 1).FillDown
               w1.Cells(i, 4).Resize(UBound(Sp) + 1).Value = Application.Transpose(Sp)
            End If
         End If
      Next i
   End With
End Sub
 
Upvote 0
Would copying sheet2 after the data in Sheet1 and then sorting on column C do what you want.
unfortunately no, there is lot of extra data in sheet2 that in not needed in sheet1. The only common cell between the two workbooks is column c
 
Upvote 0
Here another macro for you to consider

VBA Code:
Sub PGNewbie()
  Dim w1 As Worksheet, w2 As Worksheet
  Dim Cl As Range, cad As Variant, i As Long, c As Variant, irows As Variant, r As Variant
  Application.ScreenUpdating = False
  
  Set w2 = Workbooks("Book2.xlsx").ActiveSheet
  Set w1 = Workbooks("Book1.xlsx").ActiveSheet
  
  With CreateObject("scripting.dictionary")
    For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
      cad = w2.Cells(Cl.Row, "B").Value & "|" & w2.Cells(Cl.Row, "C").Value & "|" & w2.Cells(Cl.Row, "D").Value
      If Not .Exists(Cl.Value) Then
        .Add Cl.Value, cad
      Else
        .Item(Cl.Value) = .Item(Cl.Value) & "," & cad
      End If
    Next Cl
    For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
      If .Exists(w1.Cells(i, "C").Value) Then
        irows = Split(.Item(w1.Cells(i, "C").Value), ",")
        For r = UBound(irows) To LBound(irows) Step -1
          w1.Rows(i + 1).Insert
          w1.Cells(i + 1, "B").Resize(1, 3).Value = Split(irows(r), "|")
        Next
      End If
    Next
  End With
End Sub
 
Upvote 0
How about
VBA Code:
Sub PGNewbie()
   Dim w1 As Worksheet, w2 As Worksheet
   Dim Cl As Range
   Dim i As Long
   Dim Sp As Variant
   Application.ScreenUpdating = False
     
   Set w2 = Workbooks("Book2.xlsx").ActiveSheet
   Set w1 = Workbooks("Book1.xlsx").ActiveSheet
  
   With CreateObject("scripting.dictionary")
      For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
         End If
      Next Cl
      For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
         If .Exists(w1.Cells(i, 3).Value) Then
            Sp = Split(.Item(w1.Cells(i, 3).Value), "|")
            If UBound(Sp) = 0 Then
               w1.Cells(i, 4).Value = Sp(0)
            Else
               w1.Rows(i + 1).Resize(UBound(Sp)).Insert
               w1.Rows(i).Resize(UBound(Sp) + 1).FillDown
               w1.Cells(i, 4).Resize(UBound(Sp) + 1).Value = Application.Transpose(Sp)
            End If
         End If
      Next i
   End With
End Sub
Thanks Fluff, this unfortunately is changing data in workbook1, is it possible to only create a new row with column C and D being copied over from workbook2 into column C and D of the new row in Workbook1 and leaving the other columns blank?
 
Upvote 0
create a new row with column C and D

In my macro, only the highlighted lines change:

Rich (BB code):
Sub PGNewbie()
  Dim w1 As Worksheet, w2 As Worksheet
  Dim Cl As Range, cad As Variant, i As Long, c As Variant, irows As Variant, r As Variant
  Application.ScreenUpdating = False
 
  Set w2 = Workbooks("Book2.xlsx").ActiveSheet
  Set w1 = Workbooks("Book1.xlsx").ActiveSheet
 
  With CreateObject("scripting.dictionary")
    For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
      cad = w2.Cells(Cl.Row, "C").Value & "|" & w2.Cells(Cl.Row, "D").Value
      If Not .Exists(Cl.Value) Then
        .Add Cl.Value, cad
      Else
        .Item(Cl.Value) = .Item(Cl.Value) & "," & cad
      End If
    Next Cl
    For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
      If .Exists(w1.Cells(i, "C").Value) Then
        irows = Split(.Item(w1.Cells(i, "C").Value), ",")
        For r = UBound(irows) To LBound(irows) Step -1
          w1.Rows(i + 1).Insert
          w1.Cells(i + 1, "C").Resize(1, 2).Value = Split(irows(r), "|")
        Next
      End If
    Next
  End With
End Sub
 
Upvote 0
is it possible to only create a new row with column C and D being copied over from workbook2 into column C and D of the new row in Workbook1 and leaving the other columns blank?
Yes like
VBA Code:
Sub PGNewbie()
   Dim w1 As Worksheet, w2 As Worksheet
   Dim Cl As Range
   Dim i As Long
   Dim Sp As Variant
   Application.ScreenUpdating = False
      
   Set w2 = Workbooks("Book2.xlsx").ActiveSheet
   Set w1 = Workbooks("Book1.xlsx").ActiveSheet
   
   With CreateObject("scripting.dictionary")
      For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
         End If
      Next Cl
      For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
         If .Exists(w1.Cells(i, 3).Value) Then
            Sp = Split(.Item(w1.Cells(i, 3).Value), "|")
            If UBound(Sp) = 0 Then
               w1.Cells(i, 4).Value = Sp(0)
            Else
               w1.Rows(i + 1).Resize(UBound(Sp)).Insert
               w1.Cells(i, 3).Resize(UBound(Sp) + 1).FillDown
               w1.Cells(i, 4).Resize(UBound(Sp) + 1).Value = Application.Transpose(Sp)
            End If
         End If
      Next i
   End With
End Sub
 
Upvote 0
Yes like
VBA Code:
Sub PGNewbie()
   Dim w1 As Worksheet, w2 As Worksheet
   Dim Cl As Range
   Dim i As Long
   Dim Sp As Variant
   Application.ScreenUpdating = False
     
   Set w2 = Workbooks("Book2.xlsx").ActiveSheet
   Set w1 = Workbooks("Book1.xlsx").ActiveSheet
  
   With CreateObject("scripting.dictionary")
      For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "|" & Cl.Offset(, 1).Value
         End If
      Next Cl
      For i = w1.Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
         If .Exists(w1.Cells(i, 3).Value) Then
            Sp = Split(.Item(w1.Cells(i, 3).Value), "|")
            If UBound(Sp) = 0 Then
               w1.Cells(i, 4).Value = Sp(0)
            Else
               w1.Rows(i + 1).Resize(UBound(Sp)).Insert
               w1.Cells(i, 3).Resize(UBound(Sp) + 1).FillDown
               w1.Cells(i, 4).Resize(UBound(Sp) + 1).Value = Application.Transpose(Sp)
            End If
         End If
      Next i
   End With
End Sub
Thank you, this did the job!
 
Upvote 0
Glad we could help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top