[VBA] Adding data to ListObject fails

[lmolenaar]

Dear Experts,

I have little experience with VBA and believe I am stuck on a basic level. I like to read a set of columns in a row and add the read data to a specific table. The value in one of the columns decides to which table the data should be added.

I manage to create a table but I am unable to insert/add the copied data. Could someone help me? Find below a snippet of the test code:

Sub create_table()

 Dim MyRange As Range
 Dim LastRow As Long
 Dim VAR_TYPE As String
 Dim VAR_TABLE As ListObject
 Dim VAR_TABLEROW As ListRow
 Dim VAR_TESTDATA As Range
 
    ' set data type (normally read from column 1)
    VAR_TYPE = "Sprint 0"
    
    ' find latest row
    Set MyRange = ActiveSheet.Range("A1")
    LastRow = Cells(ActiveSheet.Rows.Count, MyRange.Column).End(xlUp).Row
    
    ' select correct table
    On Error Resume Next
    Set VAR_TABLE = ActiveSheet.ListObjects(VAR_TYPE)
    
    ' create table in case unavailable
    If VAR_TABLE Is Nothing Then
        ActiveSheet.ListObjects.add(xlSrcRange, Range("$A$" & LastRow + 2 & ":$L$" & LastRow + 2), , xlYes).Name = _
         VAR_TYPE
        Set VAR_TABLE = ActiveSheet.ListObjects(VAR_TYPE)
    End If
    On Error GoTo 0
        
    ' Find value "52" in colomn C (normally dynamic value)
    Columns("C:C").Select
    Set issuefound = Selection.Find(What:="52", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
    :=True, SearchFormat:=False)
    
    ' copy test data
    Set VAR_TESTDATA = Range("A" & issuefound.Row & ":L" & issuefound.Row)
    
    ' create new row in table
    VAR_TABLE.ListRows.add
    
    ' Select latest row
    Set VAR_TABLEROW = VAR_TABLE.ListRows(VAR_TABLE.ListRows.Count)
    VAR_TESTDATA
    
    ' activate range
    'VAR_TABLEROW.Range.Activate
    VAR_TESTDATA.Copy Destination:=VAR_TABLEROW
        
    ' paste data
    Set VAR_TESTDATA = VAR_TABLE.InsertRowRange
        
End Sub

 

[lmolenaar]

---
My original (unanswered) post can be found here. If my question is answered on any of the forums I will update ALL posts.

 

[lmolenaar]

I solved it by cycling through the range/cycle instead of trying to insert the copied range into the table.

Sub create_table()

 Dim MyRange As Range
 Dim LastRow As Long
 Dim VAR_TYPE As String
 Dim VAR_TABLE As ListObject
 Dim VAR_TABLEROW As ListRow
 Dim VAR_TESTDATA As Range
 Dim VAR_RANGEVALUE As Range
 Dim VAR_OFFSET As Integer
 Dim bereik As Range
 
    ' Defineer default offset
    VAR_OFFSET = 1
    
    ' test waarde (normaal uitgelezen van column 1)
    VAR_TYPE = "Sprint 0"
    
    ' zoek laatste rij
    Set MyRange = ActiveSheet.Range("A1")
    LastRow = Cells(ActiveSheet.Rows.Count, MyRange.Column).End(xlUp).Row
    
    ' selecteer juiste tabel
    On Error Resume Next
    Set VAR_TABLE = ActiveSheet.ListObjects(VAR_TYPE)
    
    ' maak tabel indien nog niet aanwezig
    If VAR_TABLE Is Nothing Then
        ActiveSheet.ListObjects.add(xlSrcRange, Range("$A$" & LastRow + 2 & ":$L$" & LastRow + 2), , xlYes).Name = _
         VAR_TYPE
        Set VAR_TABLE = ActiveSheet.ListObjects(VAR_TYPE)
        ' format time columns
        VAR_TABLE.ListColumns(7).Range.NumberFormat = "mm:ss"
        VAR_TABLE.ListColumns(8).Range.NumberFormat = "mm:ss"
    End If
    On Error GoTo 0
        
    ' Zoek test data
    Set bereik = Range("C:C")
    Set issuefound = bereik.Find(What:="52", After:=Cells(1, 3), LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
    :=True, SearchFormat:=False)
    
    ' kopieer test data
    Set VAR_TESTDATA = Range("A" & issuefound.Row & ":L" & issuefound.Row)
    Set VAR_TABLEROW = VAR_TABLE.ListRows.add(AlwaysInsert:=True)
    
    ' Verwerk elke aray waarde
    For Each VAR_RANGEVALUE In VAR_TESTDATA
        VAR_TABLEROW.Range.Cells(1, VAR_OFFSET).Value = VAR_RANGEVALUE.Value
        VAR_OFFSET = VAR_OFFSET + 1
    Next VAR_RANGEVALUE
            
        
End Sub