Макрос Excel VBA для добавления столбцов и значений поиска в двух разных книгах - PullRequest
0 голосов
/ 18 октября 2018

У меня есть три рабочие книги, рабочая книга A, рабочая книга B и рабочая книга C.

В рабочую книгу A я хочу добавить два новых столбца в конце и назвать их «Код товара» и «Код магазина».Существующие поля в Рабочей книге A: «Элемент Descr» и «Store Descr».Чтобы заполнить поле «Код товара», я должен выполнить поиск по книге B, в которой были столбцы «Код товара» и «Описание товара».И чтобы заполнить столбец «код магазина» в книге «А», мне нужно выполнить поиск в книге «С», в которой есть столбцы «код магазина» и «магазин Descr».

Я не совсем уверенкак написать это как макрос в 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))"

Но это выдает ошибку «Определено приложением»или объектная ошибка.

1 Ответ

0 голосов
/ 21 октября 2018

Я создал несколько фиктивных книг / данных с моей стороны, поскольку вы не предоставили скриншоты.

Для меня это "Лист1" в книге A, Workbook A

это «Лист1» в рабочей книге B. Workbook B

, а это «Лист1» в рабочей книге C. Workbook C

Я использую приведенный ниже код для поиска описаний предметов и хранения описаний.Вам нужно будет изменить пути к файлам на книги 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 (после запуска приведенного выше кода): enter image description here

Из-за различий между вашими рабочими книгами и моей, маловероятно, что код будет работать для вас как есть.Скорее всего, вам потребуется изменить / настроить код в определенных местах, если:

  • ваши листы в рабочей книге A, B, C названы не так, как "Sheet1"
  • ваши данные(включая заголовки) имеет другое местоположение / структуру / макет
  • есть пробелы / пропущенные элементы (которые могут привести к сбою при поиске)

Тем не менее, код и сопровождающие скриншоты могутдать вам представление о том, как это сделать.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...