Excel: fill in table from another table.

UPDATE: I am now working on replacing offsets with absolute or structured references, ie. references to Listobject Table. This will make my vba immune from inserting columns and allow hiding the source table:

Private Sub FindCopyValues()
     
     

Dim strKodRange As Range
Dim lObjSource As ListObject: Set lObjSource = Sheets("Pricelist").ListObjects("tblPricelist")
Dim lObjTarget As ListObject: Set lObjTarget = Sheets("Quote").ListObjects("tblQuote")

Dim iTableRowNum As Integer

'set cursor in first cell of column Code in tblPricelist
Dim curAddr As Range: Set curAddr = lObjTarget.DataBodyRange.Cells(1, lObjTarget.ListColumns("Code").Index)

'set what to look for
Dim strKod As String: strKod = curAddr.Value



'what offsets between Code and Price

With lObjTarget
    Dim Code2Price As Integer: Code2Price = .ListColumns("Price").Index - .ListColumns("Code").Index
    Dim Code2Description As Integer: Code2Description = .ListColumns("Description").Index - .ListColumns("Code").Index


End With



      
   Do Until strKod = ""
        
            Set Cell = lObjSource.ListColumns("Code").DataBodyRange.Cells.Find(What:=strKod, MatchCase:=False, LookAt:= _
            xlWhole, SearchFormat:=False)
            
            iTableRowNum = Cell.Row - lObjSource.DataBodyRange.Rows(1).Row + 1
            Debug.Print iTableRowNum
    
'            With Cell
'
'                   curAddr.Offset(0, Code2Price).Value = .Offset(0, 1).Value
'                   curAddr.Offset(0, Code2Description).Value = .Offset(0, 2).Value
'
'            End With
               
            'Albo
                   curAddr.Offset(0, Code2Price).Value = lObjSource.DataBodyRange.Cells(iTableRowNum, lObjSource.ListColumns("Price").Index)
                   curAddr.Offset(0, Code2Description).Value = lObjSource.DataBodyRange.Cells(iTableRowNum, lObjSource.ListColumns("Description").Index)
               
               
               
            Set curAddr = curAddr.Offset(1, 0)
            strKod = curAddr.Text
       
   Loop
       
Application.ScreenUpdating = True
Application.EnableEvents = True
   
   
End Sub

Problem z vlookupem, nie zwraca wartości wraz z linkiem do strony internetowej, zdjęcia czy dokumentu.
Rozwiązanie, np. użycie VBA

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim strKod As String
 
strKod = Sheets("Baza").Range("G4").Text
  
If Target.Address = "$G$4" Then
 
     Range("$G$4").Select
      
    With Sheets("Aku").Cells.Find(What:=strKod, after:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
            False)
             
            .Offset(0, 1).Copy Destination:=Sheets("Baza").Range("H4")
      
            .Offset(0, 2).Copy Destination:=Sheets("Baza").Range("I4")
    End With
   
    End If
 
End Sub

Powtarza się kod .Offset... więc można go połączyć w jedną linię za pomocą Union. Ponadto, nie chcę szukać w całym arkuszu a jedynie w kolumnie tabeli.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim strKod As String

strKod = Sheets("Baza").Range("G4").Text
oListObj = Sheets("Aku").ListObjects("Tabela1").ListColumns("Nazwa aku.")
 
If Target.Address = "$G$4" Then

     Range("$G$4").Select
     
    With oListObj.DataBodyRange.Cells.Find(What:=strKod, after:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
            False)
            
            Union(.Offset(0, 1), .Offset(0, 2)).Copy Destination:=Sheets("Baza").Range("H4")
     

    End With

    End If

End Sub

A co jeśli chcemy wyszukać nie tylko w komórce G4 ale w całej kolumnie?

Private Sub FindCopyValues()
   
Dim strKod As String
Dim strKodRange As Range
Dim objList As ListObject
Dim curAddr As Object
 
'Application.ScreenUpdating = False
'Application.EnableEvents = False
 
 
Set objList = Sheets("Aku").ListObjects("Tabela1")
Set curAddr = Worksheets("Baza").Range("$G$4")
   
 
    strKod = curAddr.Value
    
   Do Until strKod = ""
      
            Set cell = objList.ListColumns("Nazwa aku.").DataBodyRange.Cells.Find(What:=strKod, MatchCase:=False, LookAt:= _
            xlWhole, SearchFormat:=False)
  
            With cell
                       
                    Union(.Offset(0, 1), .Offset(0, 2)).Copy Destination:=curAddr.Offset(0, 1)
         
            End With
             
   Set curAddr = curAddr.Offset(1, 0)
   strKod = curAddr.Text
     
   Loop
     
Application.ScreenUpdating = True
Application.EnableEvents = True
 
 
End Sub

---

Inny temat: chcemy skopiować tylko widoczne wiersze do innej tabeli (niewidoczne nas nie interesują).

 

Sub CopyVisibleProducts()

Sheets("cennik").ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy Sheets("pro_forma").Range("b5")
Application.CutCopyMode = False

End Sub