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

Question

我希望有人能帮我解决这个问题。

问题：我正在创建一个将按此事件顺序工作的宏；

1. 在工作表顶部的标题下方添加一个新行。
2. 要求用户选择外部 excel 文件，将在下一部分中引用。
3. 在选择的第一个文件上使用 VLOOKUP 来填充一个单元格
4. 在选择的第二个文件上使用 VLOOKUP 来填充一系列单元格。

注意：使用 VLOOKUP 填充的单元格都在步骤 1 中刚刚创建的同一行中。

到目前为止，我有这段代码，只有当我注释掉其中一个 VLOOKUP 或其中一个被调用文件时，它才有效。 如果我尝试按原样运行代码，我会收到运行时错误“9”下标超出范围。

任何想法将不胜感激。 谢谢！

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：从两个工作簿中查找

瑕疵

• 选择 Excel 不支持的文件时，会发生错误。 例如，使用GetOpenFilename arguments 过滤文件。
• 当由于打开了错误的文件而导致源工作表不存在时，将发生错误。 介绍一些错误处理。
• 源代码块实际上是相同的（重复的），因此可以通过引入 arrays 来重构它们。

代码

• 未经测试。

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