Я создал несколько фиктивных книг / данных с моей стороны, поскольку вы не предоставили скриншоты.
Для меня это "Лист1" в книге A, ![Workbook A](https://i.stack.imgur.com/qZmkK.gif)
это «Лист1» в рабочей книге B. ![Workbook B](https://i.stack.imgur.com/dpw3b.gif)
, а это «Лист1» в рабочей книге C. ![Workbook C](https://i.stack.imgur.com/hKuD5.gif)
Я использую приведенный ниже код для поиска описаний предметов и хранения описаний.Вам нужно будет изменить пути к файлам на книги 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](https://i.stack.imgur.com/onVd5.gif)
Из-за различий между вашими рабочими книгами и моей, маловероятно, что код будет работать для вас как есть.Скорее всего, вам потребуется изменить / настроить код в определенных местах, если:
- ваши листы в рабочей книге A, B, C названы не так, как "Sheet1"
- ваши данные(включая заголовки) имеет другое местоположение / структуру / макет
- есть пробелы / пропущенные элементы (которые могут привести к сбою при поиске)
Тем не менее, код и сопровождающие скриншоты могутдать вам представление о том, как это сделать.