Matching cells and creating a new worksheet

[swamprat]

Hello Excel Experts,

I have 2 Excel files, the first has cells with the following data:

[Name] [Cost] [Date]

The second file has:

[Name] [SKU] [Serial Numbers (can be more than 1)]

I'm trying to combine these into a new file with: [Name] [SKU] [Serial Numbers] [Cost], based on the matching the cells in the Name column. How can I do this please?

Thanks very much for any help.

 

[DanteAmor]

Put the following macro in a new file.


Open Excel 1 and 2 books.
Run the macro. The results will be on the first sheet.

Change the names in red to the names of your files.

Sub combine_books()
  Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet
  Dim c As Range, r As Range, f As Range, cell As String, j As Long
  Application.ScreenUpdating = False
  Set sh = Sheets("combine")
  Set sh1 = Workbooks("[COLOR=#ff0000]excel1[/COLOR].xlsx").Sheets(1)
  Set sh2 = Workbooks("[COLOR=#ff0000]excel2[/COLOR].xlsx").Sheets(1)
  sh.Rows("2:" & Rows.Count).ClearContents
  Set r = sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
  '
  j = 2
  For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c, , xlValues, xlWhole)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        sh.Range("A" & j).Value = c
        sh.Range("B" & j).Value = f.Offset(, 1)
        sh.Range("C" & j).Value = f.Offset(, 2)
        sh.Range("D" & j).Value = c.Offset(, 1)
        j = j + 1
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[swamprat]

Hola Dante,

Thanks so much for your response.

I tried your suggestion and it seems to work until it finds a cell which doesn't match, at which point I get an 'Application-defined or object-defined error' on this line:

 sh.Range("C" & j).Value = f.Offset(, 2)

Most likely I have done something wrong!

Saludos

Put the following macro in a new file.


Open Excel 1 and 2 books.
Run the macro. The results will be on the first sheet.

Change the names in red to the names of your files.

Sub combine_books()
  Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet
  Dim c As Range, r As Range, f As Range, cell As String, j As Long
  Application.ScreenUpdating = False
  Set sh = Sheets("combine")
  Set sh1 = Workbooks("[COLOR=#ff0000]excel1[/COLOR].xlsx").Sheets(1)
  Set sh2 = Workbooks("[COLOR=#ff0000]excel2[/COLOR].xlsx").Sheets(1)
  sh.Rows("2:" & Rows.Count).ClearContents
  Set r = sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
  '
  j = 2
  For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c, , xlValues, xlWhole)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        sh.Range("A" & j).Value = c
        sh.Range("B" & j).Value = f.Offset(, 1)
        sh.Range("C" & j).Value = f.Offset(, 2)
        sh.Range("D" & j).Value = c.Offset(, 1)
        j = j + 1
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[DanteAmor]

Maybe you have some cells with error.
Try the following and tell me the result.

Sub combine_books()
  Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet
  Dim c As Range, r As Range, f As Range, cell As String, j As Long
  Application.ScreenUpdating = False
  Set sh = Sheets("combine")
  Set sh1 = Workbooks("excel1.xlsx").Sheets(1)
  Set sh2 = Workbooks("excel2.xlsx").Sheets(1)
  sh.Rows("2:" & Rows.Count).ClearContents
  Set r = sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
[COLOR=#0000ff]  On Error Resume Next[/COLOR]
  j = 2
  For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c, , xlValues, xlWhole)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        sh.Range("A" & j).Value = c
        sh.Range("B" & j).Value = f.Offset(, 1)
        sh.Range("C" & j).Value = f.Offset(, 2)
        sh.Range("D" & j).Value = c.Offset(, 1)
        j = j + 1
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[swamprat]

That seems to work perfectly.

Thanks very much Dante.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.