Question

我有三个工作簿，即工作簿A，工作簿B和工作簿C。

对于工作簿A，我想在末尾添加两个新列，并将它们称为“项目代码”和“商店代码”。工作簿A中的现有字段为“项目描述”和“存储描述”。为了填充字段“项目代码”，我必须对具有列“项目代码”和“项目描述”的工作簿B执行查找。并且为了填充工作簿A中的“商店代码”列，我必须对工作簿C进行查找，该工作簿C具有列“商店代码”和“商店描述”。

我不太确定如何在VBA中将其编写为宏：(有人可以帮我吗？

到目前为止，这是我的代码：

Sub Macro1()

Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Set ws = Sheet1   ' NOTE: Change this if your data is not in Sheet1.

With ws
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

    .Cells(1, LastCol + 1).Value = "Brand_item"
    .Cells(1, LastCol + 2).Value = "Brand_code"
End With

Range("A2").Select
Selection.End(xlToRight).Select
Range("G2").Select
Windows("PE CLOSING OCT R2trial.xls").Activate
ActiveCell.FormulaR1C1 = _
    "=INDEX([PEcodez.xlsx]Sheet1!R1C2:R2338C2,MATCH(RC[-3], 
 [PEcodez.xlsx]Sheet1!R1C1:R2338C1,0))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G2110")
Range("G2:G2110").Select
Range("G2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("H2").Select
Application.CutCopyMode = False
Windows("PE CLOSING OCT R2trial.xls").Activate
ActiveCell.FormulaR1C1 = _
    "=INDEX([PEdoorcodes.xlsx]Sheet1!R1C3:R29C3,MATCH(RC[-7],[PEdoorcodes.xlsx]Sheet1!R1C1:R29C1,0))"
Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H2110")
Range("H2:H2110").Select
Range("H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("H2").Select
Application.CutCopyMode = False

End Sub

谢谢

我只是不确定如何包括工作簿的文件路径。

更新，我尝试使用以下代码更新路径：

ActiveCell.FormulaR1C1 = _
    "=INDEX(C:\Users\amy\Documents\amyTrial\[PEcodez.xlsx]Sheet1!$A:$A,MATCH(RC[-3],C:\Users\amy\Documents\amy\[PEcodez.xlsx]Sheet1!R1C1:R2338C1,0))"

但是它给了我应用程序定义或对象定义的错误。

Answer 1

由于您没有提供屏幕截图，因此我最终创建了一些虚拟工作簿/数据。

对我来说，这是工作簿A中的“ Sheet1”，

这是工作簿B中的“ Sheet1”。

，这是工作簿C中的“ Sheet1”。

我使用下面的代码查找商品说明和商店说明。您需要在代码本身中更改工作簿B和C的文件路径（前提是您将代码本身放在工作簿A中并从那里运行）。

Option Explicit

Private Sub lookupDescriptions()

    Dim pathToWorkbookB As String
    pathToWorkbookB = "C:\Users\User\Desktop\New folder\3 workbooks\B.xlsx" ' Change this to the real file path.

    Dim pathToWorkbookC As String
    pathToWorkbookC = "C:\Users\User\Desktop\New folder\3 workbooks\C.xlsx" ' Change this to the real file path.

    Dim workbookB As Workbook ' Contains: Item code, item descr
    Set workbookB = OpenWorkbook(pathToWorkbookB)
    If workbookB Is Nothing Then
        MsgBox ("Could not locate workbook B at the path below" & vbNewLine & vbNewLine & pathToWorkbookB & vbNewLine & vbNewLine & "Check file path provided. Code will stop running now.")
        Exit Sub
    End If

    Dim workbookC As Workbook ' Contains: Store code, store descr
    Set workbookC = OpenWorkbook(pathToWorkbookC)
    If workbookC Is Nothing Then
        MsgBox ("Could not locate workbook C at the path below" & vbNewLine & vbNewLine & pathToWorkbookC & vbNewLine & vbNewLine & "Check file path provided. Code will stop running now.")
        Exit Sub
    End If

    ' Workbooks A and B both contain "Item code",
    ' Get "Item description" from workbook B for each match
    With ThisWorkbook.Worksheets("Sheet1")
        Dim itemCodesInA As Range
        Set itemCodesInA = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)

        Dim storeCodesInA As Range
        Set storeCodesInA = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With

    With workbookB.Worksheets("Sheet1")
        Dim itemCodesInB As Range
        Set itemCodesInB = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)

        Dim itemDescriptionsInB As Range
        Set itemDescriptionsInB = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With

    ' Workbooks A and C both contain "Store code",
    ' Get "Store description" from workbook C for each match
    With workbookC.Worksheets("Sheet1")
        Dim storeCodesInC As Range
        Set storeCodesInC = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)

        Dim storeDescriptionsInC As Range
        Set storeDescriptionsInC = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With

    ' This is workbook A, change sheet name if necessary
    With ThisWorkbook.Worksheets("Sheet1")
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Dim lastColumn As Long
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

        .Cells(1, lastColumn + 1).Value2 = "Item description"
        With .Range(.Cells(2, lastColumn + 1), .Cells(lastRow, lastColumn + 1))
            .Formula = "=INDEX(" & itemDescriptionsInB.Address(True, True, xlA1, True) & ",MATCH(" & itemCodesInA(1).Address(False, True, xlA1, False) & "," & itemCodesInB.Address(True, True, xlA1, True) & ",0))"
            .Value2 = .Value2 ' Comment/delete this line to keep formulas
        End With

        .Cells(1, lastColumn + 2).Value2 = "Store description"
        With .Range(.Cells(2, lastColumn + 2), .Cells(lastRow, lastColumn + 2))
            .Formula = "=INDEX(" & storeDescriptionsInC.Address(True, True, xlA1, True) & ",MATCH(" & storeCodesInA(1).Address(False, True, xlA1, False) & "," & storeCodesInC.Address(True, True, xlA1, True) & ",0))"
            .Value2 = .Value2 ' Comment/delete this line to keep formulas
        End With
    End With

    ' Close workbooks without saving
    If Not (workbookB Is Nothing) Then workbookB.Close False
    If Not (workbookC Is Nothing) Then workbookC.Close False
End Sub

Private Function OpenWorkbook(ByVal fullPathToWorkbook As String) As Workbook
    If Len(Dir$(fullPathToWorkbook, vbNormal)) = 0 Then
        Exit Function
    End If

    Dim workbookName As String
    workbookName = VBA.Strings.Mid$(fullPathToWorkbook, VBA.Strings.InStrRev(fullPathToWorkbook, "\", -1, vbBinaryCompare) + 1)

    Dim outputWorkbook As Workbook

    On Error Resume Next
    Set outputWorkbook = Application.Workbooks(workbookName)
    On Error GoTo 0

    If outputWorkbook Is Nothing Then
        Set outputWorkbook = Application.Workbooks.Open(fullPathToWorkbook)
    End If

    Set OpenWorkbook = outputWorkbook
End Function

我在工作簿A中得到的内容（运行上面的代码后）是：

由于您的工作簿和我的工作簿之间的差异，因此该代码不太可能照原样工作。如果发生以下情况，您可能需要在某些位置更改/调整代码：

您在工作簿A，B，C中的工作表命名为“ Sheet1”以外的其他名称
您的数据（包括标题）具有不同的位置/结构/布局
存在空白/缺失项（这将导致查找失败）

尽管如此，代码和随附的屏幕截图可能会为您提供有关操作方法的想法。

Excel VBA宏可在两个不同的工作簿中添加列和查找值

1 个答案: