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

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
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

B
  • Question
Excel 365 Compare Date & Copy Cell Data for Data Base
2 3 4
Replies
33
Views
759
skillilea
S
JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
875
kevin9999
K
T
  • Question
Dealing with duplicate numbers in dictionary
Replies
1
Views
304
bebo021999
B
T
  • Question
Import Data to check if it exists and if not add to existing data
Replies
9
Views
488
Ti1164
T
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
628
kevin9999
K

Forum statistics

Threads
1,214,920
Messages
6,122,267
Members
449,075
Latest member
staticfluids

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