使用两个外部工作簿在 VBA 中进行 VLOOKUP

Question

I am hoping someone can help me with this.

The Problem: I am creating a macro that will work in this order of events;

1. Add a new row to the top of the sheet, under the headers.
2. Ask the user to choose to external excel files that will be used to be referenced to in the next part.
3. Use VLOOKUP on the first file chosen to fill in one cell
4. Use VLOOKUP on the second file chose to fill in a range of cells.

Note: the cells that are being filled in using VLOOKUP are all on the same row that was just created in step 1.

I have this code so far and it works only when either I comment out one of the VLOOKUPs or one of the called files. If I try run the code as is, I get a Run-time error '9' Subscript out of range.

Any ideas would be every appreciated. Thank you!

Sub PWGS_Import_P2_MerickID()
'This macro is to fill out the PWGS Tracker using VLOOKUP for the Merrick IDs from the Shipped and Incoming Meter files from Carte; It will ask for two files to be opened. 1st is Incoming, then Shipped


'Definitions
Dim PWGS As Workbook
Dim BlackSail_P2 As Worksheet
Dim BlackSail_P2_Incoming As Range
Dim BlackSail_P2_Shipped As Range


Set PWGS = ThisWorkbook
Set BlackSail_P2 = PWGS.Worksheets("Black Sail (Pipeline 2)")

'adding a new row
Sheets(Array("Black Sail (Pipeline 2)")).Select
Sheets("Black Sail (Pipeline 2)").Activate
Rows("5:5").Select
Selection.Copy
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Rows("5:5").Select
Selection.ClearContents

'opening P2_Incoming file
Dim fNameAndPath As Variant, P2_Incoming As Workbook
fNameAndPath = Application.GetOpenFilename
If fNameAndPath = False Then Exit Sub
Set P2_Incoming = Workbooks.Open(fNameAndPath)

'opening P2_Shipped file
Dim fNameAndPath_2 As Variant, P2_Shipped As Workbook
fNameAndPath_2 = Application.GetOpenFilename
If fNameAndPath_2 = False Then Exit Sub
Set P2_Shipped = Workbooks.Open(fNameAndPath_2)

'LOOPS
With P2_Incoming
For Each BlackSail_P2_Incoming In Range("B5")
BlackSail_P2_Incoming.Value = _
Application.WorksheetFunction.VLookup(BlackSail_P2_Incoming.Offset(-2, 0), _
Sheets("PWGS Incoming Meters").Range("C:D"), 2, 0)
Next
End With


With P2_Shipped
For Each BlackSail_P2_Shipped In Range("F5:J5")

BlackSail_P2_Shipped.Value = _
Application.WorksheetFunction.VLookup(BlackSail_P2_Shipped.Offset(-2, 0), _
Sheets("PWGS Shipped Meters").Range("C:D"), 2, 0)
    
Next BlackSail_P2_Shipped
End With

End Sub

Answer 1

A VBA Lookup: Lookup From Two Workbooks

Flaws

• When selecting a file that's not supported by Excel an error will occur. Use the GetOpenFilename arguments to eg filter the files.
• When a source worksheet doesn't exist because a wrong file was opened, an error will occur. Introduce some error handling.
• The source code blocks are practically the same (repetitive) so they could be refactored by introducing arrays.

The Code

• Not tested.

Sub PWGS_Import_P2_MerickID()

    ' Destination: Black Sail
    Const dwsName As String = "Black Sail (Pipeline 2)"
    Const dLookupRow As Long = 3 ' 1.) Lookup this...  7.) Lookup this...
    Const dInsertRow As Long = 5 ' 5.) ... here...  11.) ... here...
    Const diColumns As String = "B" ' 2.) ... and this... 6.) ... and here.
    Const dsColumns As String = "F:J" ' 8.) ... and this...  12.) ... and here.
    ' Source: Incoming
    Const iwsName As String = "PWGS Incoming Meters"
    Const iLookupColumn As String = "C" ' 3.) ... here...
    Const iValueColumn As String = "D"  ' 4.) ... and return this...
    ' Source: Shipped
    Const swsName As String = "PWGS Shipped Meters"
    Const sLookupColumn As String = "C" ' 9.) ... here...
    Const sValueColumn As String = "D"  ' 10.) ... and return this...
    
    ' Destination: Black Sail
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
    Dim drOffset As Long: drOffset = dInsertRow - dLookupRow
    Dim dcCount As Long
    dcCount = dws.Cells(dLookupRow, dws.Columns.Count).End(xlToLeft)
    Dim dlrg As Range: Set dlrg = dws.Cells(dLookupRow, "A").Resize(, dcCount)
    dlrg.Offset(drOffset).Insert xlShiftDown, xlFormatFromRightOrBelow
    
    Dim dCell As Range ' Destination (Lookup) Cell
    Dim srIndex As Variant ' Source (Match) Row Index
    
    Application.ScreenUpdating = False
    
    ' Source: Incoming
    
    Dim iFilePath As Variant: iFilePath = Application.GetOpenFilename
    If iFilePath = False Then Exit Sub
    Dim iwb As Workbook: Set iwb = Workbooks.Open(iFilePath)
    Dim iws As Worksheet: Set iwb = iwb.Worksheets(iwsName)
    
    For Each dCell In dlrg.Columns(diColumns).Cells
        srIndex = Application.Match(dCell.Value, iws.Columns(iLookupColumn), 0)
        If IsNumeric(srIndex) Then
            dCell.Offset(drOffset).Value _
                = iws.Cells(srIndex, iValueColumn).Value
        End If
    Next
    
    'iwb.Close SaveChanges:=False

    ' Source: Shipped
    
    Dim sFilePath As Variant: sFilePath = Application.GetOpenFilename
    If sFilePath = False Then Exit Sub
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    Dim sws As Worksheet: Set swb = swb.Worksheets(swsName)
    
    For Each dCell In dlrg.Columns(dsColumns).Cells
        srIndex = Application.Match(dCell.Value, sws.Columns(sLookupColumn), 0)
        If IsNumeric(srIndex) Then
            dCell.Offset(drOffset).Value _
                = sws.Cells(srIndex, sValueColumn).Value
        End If
    Next
    
    'swb.Close SaveChanges:=False

    'dwb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data imported.", vbInformation

End Sub