Create a new line for each match instead of concatenate

P

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

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
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
mikerickson said:
Would copying sheet2 after the data in Sheet1 and then sorting on column C do what you want.
Click to expand...
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
Fluff said:
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
Click to expand...
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
PGNewbie said:
create a new row with column C and D
Click to expand...

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
PGNewbie said:
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?
Click to expand...
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
Fluff said:
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
Click to expand...
Thank you, this did the job!
 
Upvote 0
Glad we could help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Delete Row if value in column C is a duplicate
Replies
8
Views
248
igold
igold
B
  • Question Question
Excel 365 Compare Date & Copy Cell Data for Data Base
2 3 4
Replies
33
Views
1K
skillilea
S
JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
1K
kevin9999
K
T
  • Question Question
Dealing with duplicate numbers in dictionary
Replies
1
Views
470
bebo021999
B
T
  • Question Question
Import Data to check if it exists and if not add to existing data
Replies
9
Views
697
Ti1164
T

Forum statistics

Threads
1,223,264
Messages
6,171,081
Members
452,377
Latest member
bradfordsam

Share this page

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