Я пытаюсь заполнить таблицу данными из другого листа на основе результата Vlookup.

Диапазон Sheet1 ("ReceiverNum") имеет числовые данные, которые будут искать из Sheet4 ("transcTable"), и когда я запускаю Sub, он фактически нашел "совпадающий номер", однако он продолжает записывать данные до конца в целевую таблицу. Также какой код мне нужно добавить для обработки ошибки, если данные не найдены?

Вот мой код:

Dim ws As Worksheet
Dim intItems As Integer
Dim cellx As Range, rowX As Range
Set rowX = Sheet1.Range("A12")


Application.EnableEvents = False
Application.ScreenUpdating = False
 For Each ws In ActiveWorkbook.Worksheets
  ws.Unprotect
 Next ws


 Range("date").Value = Application.VLookup(Range("receiptNum"), Range("transcTable"), 2, False) 'Date
 Range("name").Value = Application.VLookup(Range("receiptNum"), Range("transcTable"), 3, False) 'Name


 intItems = 0
 For Each cellx In Range("receiptNumRec")
  CellXRow = CellXRow + 1
  If Range("receiptNum").Value > "" Then
   intItems = intItems + 1
    rowX.Offset(intItems - 1, 1).Value = Application.VLookup(Range("receiptNum"), Range("transcTable"), 1, False)
     If rowX.Offset(intItems - 1, 1).Value > "" Then
      rowX.Offset(intItems - 1).Value = intItems 'Item Num
     End If


  End If
 Next cellx


 For Each ws In ActiveWorkbook.Worksheets
  ws.Protect , DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
 Next ws
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
0
markkeith 6 Сен 2020 в 06:52

1 ответ

Лучший ответ

Мой обходной путь - использовать ListObjects.Range.AdvancedFilter, а затем выполнить цикл vlookup для извлеченной таблицы, я знаю, что это сложный код, но, по крайней мере, он работает. AdvancedFilter - отличная функция, только если исходная и целевая таблица идентичны по формату и количеству столбцов.

Dim ws As Worksheet, numX
numX = Application.VLookup(Range("receiptNum"), Sheet4.Range("transcTable"), 1, False)

If Not IsError(numX) Then
Application.EnableEvents = False
Application.ScreenUpdating = False
 For Each ws In ActiveWorkbook.Worksheets
  ws.Unprotect
 Next ws
 
  With Sheet4
    If Sheet1.Cells(8, 6) <> "" Then
      .Cells(1, 10).CurrentRegion.ClearContents
      .Cells(1, 19) = .Cells(1).Value
      .Cells(2, 19) = Sheet1.Cells(8, 6)
      .ListObjects(1).Range.AdvancedFilter 2, .Range("S1:S2"), .Cells(1, 10)
    End If
  End With
 Range("pickSlipClear,contactDetails").ClearContents
 Call transcSearch 'run Search function
 Cells(Rows.Count, "C").End(xlUp).Offset(2).Select
    
 For Each ws In ActiveWorkbook.Worksheets
  ws.Protect , DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
 Next ws
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 
Else
 MsgBox "Receipt Number doesn't exist!"
 Cells(Rows.Count, "C").End(xlUp).Offset(2).Select
 
End If
End Sub

Sub transcSearch()
Dim i As Integer
Dim lng As Long
Dim xcell As Range, rowX As Range
Set rowX = Sheet1.Cells(12, 1)

 Range("date").Value = Application.VLookup(Range("receiptNum"), Sheet4.Range("transcTable"), 2, False) 'Date
 Range("name").Value = Application.VLookup(Range("receiptNum"), Sheet4.Range("transcTable"), 3, False) 'Name
   i = 0
   lng = 0
   For Each xcell In Range("prodX")
    i = i + 1
    lng = lng + 1
    If xcell.Value > "" Then
      rowX.Offset(lng - 1).Value = i 'Item Num
      rowX.Offset(lng - 1, 1).Value = Application.VLookup(xcell.Value, Sheet4.Range("filterX"), 2, False) 'Type
      rowX.Offset(lng - 1, 2).Value = Application.VLookup(xcell.Value, Sheet4.Range("filterX"), 1, False) 'Description
      rowX.Offset(lng - 1, 3).Value = Application.VLookup(xcell.Value, Sheet4.Range("filterX"), 3, False) 'Qty
      rowX.Offset(lng - 1, 4).Value = Application.VLookup(xcell.Value, Sheet4.Range("filterX"), 4, False) 'Unit
      rowX.Offset(lng - 1, 7).formula = "=IFERROR(INDEX(dataTable[ON-HAND],MATCH(@desc,dataTable[Product Description],0)),0)" ' Available stock
      rowX.Offset(lng - 1, 8).formula = "=IFERROR(INDEX(dataTable[Supplier],MATCH(@desc,dataTable[Product Description],0)),0)" 'Stock cost price
    End If
   Next xcell
End Sub
0
markkeith 11 Сен 2020 в 22:23