Macro VBA: Match text cells across two workbooks and paste

Question

I need help modifying a macro that matches the part number (Column C) between two sheets in different workbooks. Then it pastes the info from 'Original' sheet from the range P9:X6500 into the 'New' sheet into the range P9:X6500. The first sheet 'Original' in column C range C9:C6500 is the matching part number column. The 'New' sheet has the same column C with the part number to match. I only want match and paste the visible values.

I originally had this macro code which copy pastes only visible values from one workbook to another that I would like to modify it to match and copy paste:

Sub GetDataDemo()
Const FileName As String = "Original.xlsx"
Const SheetName As String = "Original"
FilePath = "C:\Users\me\Desktop\"
Dim wb As Workbook
Dim this As Worksheet
Dim i As Long, ii As Long

Application.ScreenUpdating = False

If IsEmpty(Dir(FilePath & FileName)) Then

    MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Else

    Set this = ActiveSheet

    Set wb = Workbooks.Open(FilePath & FileName)

With wb.Worksheets(SheetName).Range("P9:X500")
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy this.Range("P9")
On Error GoTo 0
End With

End If


ThisWorkbook.Worksheets("NEW").Activate

End Sub

Also here is what I want it to look like:

Original

NEW

I appreciate the help!

are you just copying from one range to the matching range in the other sheet? — QHarr
if so something like: b.Worksheets(SheetName).Range("P9:X500").Copy this.Range("P9") — QHarr
Yes, I am but I want to add a match (if-then I think?) function that also omits the hidden values. — Blackfyre
A direct copy and paste VBA operation does not copy hidden rows. — user4039065

QHarr QHarr · Accepted Answer · 2017-10-13T19:16:49

try the following where it copies the range from one sheet to the other. You can break up With wb.Worksheets(SheetName).Range("P9:X500") into With wb.Worksheets(SheetName) then use .Range("P9:X500").Copy this.Range("P9") inside the With statement. Avoid using names like i or ii or this and use something more descriptive. The error handling is essentially only dealing with Sheets not being present and i think better handling of that scenario could be done. Finally, you need to turn ScreenUpdating back on to view changes.

Option Explicit

Public Sub GetDataDemo()

    Const FILENAME As String = "Original.xlsx"
    Const SHEETNAME As String = "Original"
    Const FILEPATH As String = "C:\Users\me\Desktop\"
    Dim wb As Workbook
    Dim this As Worksheet                        'Please reconsider this name

    Application.ScreenUpdating = False

    If IsEmpty(Dir(FILEPATH & FILENAME)) Then
        MsgBox "The file " & FILENAME & " was not found", , "File Doesn't Exist"
    Else
        Set this = ActiveSheet
        Set wb = Workbooks.Open(FILEPATH & FILENAME)

        With wb.Worksheets(SHEETNAME)
            'On Error Resume Next ''Not required here unless either of sheets do not exist
            .Range("P9:X500").Copy this.Range("P9")
            ' On Error GoTo 0
        End With

    End If

    ThisWorkbook.Worksheets("NEW").Activate
    Application.ScreenUpdating = True            ' so you can see the changes

End Sub

UPDATE: As OP wants to match between sheets on column C in both and paste associated row information across (Col P to Col X) second code version posted below

Version 2:

Option Explicit

Public Sub GetDataDemo()

    Dim wb As Workbook
    Dim lookupRange As Range
    Dim matchRange As Range

    Set wb = ThisWorkbook
    Set lookupRange = wb.Worksheets("Original").Range("C9:C500")
    Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")

    Dim lookupCell As Range
    Dim matchCell As Range

    With wb.Worksheets("Original")

        For Each lookupCell In lookupRange

            For Each matchCell In matchRange
                If Not IsEmpty(matchCell) And matchCell = lookupCell Then 'assumes no gaps in lookup range
                    matchCell.Offset(0, 13).Resize(1, 9).Value2 = lookupCell.Offset(0, 13).Resize(1, 9).Value2
                End If

            Next matchCell

        Next lookupCell

    End With

    ThisWorkbook.Worksheets("NEW").Activate
    Application.ScreenUpdating = True

End Sub

You may need to amend a few lines to suit your environment e.g. change this to meet your sheet name (pasting to).

Set matchRange = wb.Worksheets("ThisSheet").Range("C9:C500")

Macro VBA: Match text cells across two workbooks and paste

1 Answers