Pulling data from sheet to table on another sheet with excel VBA

DanSMT

Board Regular
Joined
Sep 13, 2019
Messages
203
Office Version
  1. 2013
Platform
  1. Windows
All, Im trying to pull data from a sheet and sort it into a table on a secondary sheet. THe data is transfering over, but its not move to the first row in the table and working down. It appears to skip the first row. I've also created a clear form button. Whne I run this macro it clears the data, but if I run the data pull macro, it pulls it to the bottom of where the last information was deleted.

2 questions in conclusionl;

1. Why isnt the information transfering into the tables first row and working down?
2. Why after i use the delete function does the data continue from the end of the last item that was deleted?

VBA script below;

VBA Code:
Option Explicit

Sub test()
    
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim LastRowSource As Long, LastRowDestination As Long
    Dim i As Long, y As Long
    Dim Value_1 As String, Value_2 As String
    Dim ValueExists As Boolean
    
    With ThisWorkbook
        Set wsSource = .Worksheets("Data Dump")
        Set wsDestination = .Worksheets("Calc")
    End With
    
    With wsSource
    
        'Find the last row of Column A, wsSource
        LastRowSource = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        'Loop Column A, wsSource
        For i = 1 To LastRowSource
        
            'Testing Columns F & G
            Value_1 = .Range("F" & i).Value
            Value_2 = .Range("G" & i).Value
            
            ValueExists = False
            
            With wsDestination
            
            
            Dim tblInv As ListObject
            Set tblInv = .ListObjects("Table3")
            
                'Find the last row of Column A, wsDestination
                LastRowDestination = tblInv.Range.Offset.Rows.Count
                
                'Loop Column A, wsDestination
                For y = 1 To LastRowDestination
                
                    If .Range("A" & y).Offset(2).Value = Value_1 And .Range("B" & y).Value = Value_2 Then
                        ValueExists = True
                        Exit For
                    End If
                    
                Next y
                
                'If value does not exist copy
                If ValueExists = False Then
                    .Range("F" & LastRowDestination + 1).Value = Value_1
                    .Range("A" & LastRowDestination + 1).Value = Value_2
                    .Range("B" & LastRowDestination + 1).Value = wsSource.Range("L" & i).Value
                    .Range("D" & LastRowDestination + 1).Value = wsSource.Range("R" & i).Value
                    .Range("E" & LastRowDestination + 1).Value = wsSource.Range("D" & i).Value
                    .Range("G" & LastRowDestination + 1).Value = wsSource.Range("H" & i).Value
                    .Range("I" & LastRowDestination + 1).Value = wsSource.Range("C" & i).Value
                    .Range("J" & LastRowDestination + 1).Value = wsSource.Range("V" & i).Value
                    .Range("K" & LastRowDestination + 1).Value = wsSource.Range("M" & i).Value
                    .Range("M" & LastRowDestination + 1).Value = "=VLOOKUP($L2,Defects2!Print_Area,2,FALSE)"
                    .Range("O" & LastRowDestination + 1).Value = wsSource.Range("N" & i).Value
                    .Range("R" & LastRowDestination + 1).Value = wsSource.Range("O" & i).Value
                    .Range("S" & LastRowDestination + 1).Value = wsSource.Range("P" & i).Value
                End If
                
            End With
            
        Next i
        
    End With
    
End Sub

Sub test2()

With Sheets("Calc").ListObjects("Table3")
   If Not .DataBodyRange Is Nothing Then
   'Clear contents of table
   .DataBodyRange.ClearContents
   End If
End With

End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Got it!

I had to change the LastRowDestination identifier to find values as shown below. This will target first available row in table and fill downward.

I;ve also fixed the table clear section by changing .clearcontents to .delete

VBA Code:
Option Explicit

Sub test()
    
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim LastRowSource As Long, LastRowDestination As Long
    Dim i As Long, y As Long
    Dim Value_1 As String, Value_2 As String
    Dim ValueExists As Boolean
    
    With ThisWorkbook
        Set wsSource = .Worksheets("Data Dump")
        Set wsDestination = .Worksheets("Calc")
    End With
    
    With wsSource
    
        'Find the last row of Column A, wsSource
        LastRowSource = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        'Loop Column A, wsSource
        For i = 1 To LastRowSource
        
            'Testing Columns F & G
            Value_1 = .Range("F" & i).Value
            Value_2 = .Range("G" & i).Value
            
            ValueExists = False
            
            With wsDestination
            
                'Find the last row of Table3, wsDestination
                Dim rng As Range
                Set rng = .ListObjects("Table3").Range
                
                LastRowDestination = rng.Find(what:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
                
                
                'Loop Column A, wsDestination
                For y = 1 To LastRowDestination
                
                    If .Range("A" & y).Offset(1).Value = Value_1 And .Range("B" & y).Value = Value_2 Then
                        ValueExists = True
                        Exit For
                    End If
                    
                Next y
                
                'If value does not exist copy
                If ValueExists = False Then
                    .Range("F" & LastRowDestination + 1).Value = Value_1
                    .Range("A" & LastRowDestination + 1).Value = Value_2
                    .Range("B" & LastRowDestination + 1).Value = wsSource.Range("L" & i).Value
                    .Range("D" & LastRowDestination + 1).Value = wsSource.Range("R" & i).Value
                    .Range("E" & LastRowDestination + 1).Value = wsSource.Range("D" & i).Value
                    .Range("G" & LastRowDestination + 1).Value = wsSource.Range("H" & i).Value
                    .Range("I" & LastRowDestination + 1).Value = wsSource.Range("C" & i).Value
                    .Range("J" & LastRowDestination + 1).Value = wsSource.Range("V" & i).Value
                    .Range("K" & LastRowDestination + 1).Value = wsSource.Range("M" & i).Value
                    .Range("M" & LastRowDestination + 1).Value = "=VLOOKUP($L2,Defects2!Print_Area,2,FALSE)"
                    .Range("O" & LastRowDestination + 1).Value = wsSource.Range("N" & i).Value
                    .Range("R" & LastRowDestination + 1).Value = wsSource.Range("O" & i).Value
                    .Range("S" & LastRowDestination + 1).Value = wsSource.Range("P" & i).Value
                End If
                
            End With
            
        Next i
        
    End With
    
End Sub

Sub test2()

With Sheets("Calc").ListObjects("Table3")
   If Not .DataBodyRange Is Nothing Then
   'Clear contents of table
   .DataBodyRange.Delete
   End If
End With

End Sub

Code above for those who may need assistance.
 
Upvote 0
Solution

Forum statistics

Threads
1,223,893
Messages
6,175,244
Members
452,622
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top