VBA Code Performance Tunning

[Guinaba]

Hey guys,

I am using the code below to copy the data from a range and paste into a table. I am deleting the data in the table everytime beforing copying the new range. Just wondering if there is a way to make this code run faster?

Sub CopyFromRange ()

  Dim wrksht As Worksheet
  Dim objListObj As ListObject
  
  Set wrksht = ActiveWorkbook.Worksheets("IBPData1")
  Set objListObj = wrksht.ListObjects("tFcst_1")
  
   With Sheets("IBPData1")
     'Find the last non-blank cell in column A(1)
      LRow = .Cells(Rows.Count, 2).End(xlUp).Row
             
    'Clean Table content
    With objListObj.DataBodyRange
        If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        On Error Resume Next
        .Rows(1).SpecialCells(xlCellTypeConstants).ClearContents
    End With
    
   'Copy Source Range
    .Range(Cells(3, 2), Cells(LRow, 6)).Copy
    .Range("H3:L" & LRow).PasteSpecial xlPasteValues
    'Remove the animation around the copied cell
     Application.CutCopyMode = False
  
    objListObj.Resize Range("H2:L" & LRow)
   
    End With
End Sub

 

[Skyybot]

Try this.

Sub CopyFromRange ()

  Dim wrksht As Worksheet
  Dim objListObj As ListObject
  Application.ScreenUpdating = False
  Set wrksht = ActiveWorkbook.Worksheets("IBPData1")
  Set objListObj = wrksht.ListObjects("tFcst_1")
  
   With Sheets("IBPData1")
     'Find the last non-blank cell in column A(1)
      LRow = .Cells(Rows.Count, 2).End(xlUp).Row
             
    'Clean Table content
    With objListObj.DataBodyRange
        If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        On Error Resume Next
        .Rows(1).SpecialCells(xlCellTypeConstants).ClearContents
    End With
    
   'Copy Source Range
    .Range(Cells(3, 2), Cells(LRow, 6)).Copy
    .Range("H3:L" & LRow).PasteSpecial xlPasteValues
    'Remove the animation around the copied cell
     Application.CutCopyMode = False
  
    objListObj.Resize Range("H2:L" & LRow)
   
    End With
Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

Can you start with replacing the 5 lines you have under "Clean Table Contents" with this one line.

    objListObj.DataBodyRange.Delete

I suspect that won't make much difference in speed and if that is the case then,
• How much data are you copying in ?
• It looks to me that the data you are copying in in on the same sheet and next to your table, is that the case ?
• Can you give an XL2BB of your original data (Headings and a few lines) and of the Table ?

 

[Alex Blakenburg]

Give this a try and if there is no change please answer the questions in my previous post

Sub CopyFromRange()

  Dim wrksht As Worksheet
  Dim objListObj As ListObject
  Dim LRow As Long
  
  Set wrksht = ActiveWorkbook.Worksheets("IBPData1")
  Set objListObj = wrksht.ListObjects("tFcst_1")
  
   With Sheets("IBPData1")
     'Find the last non-blank cell in column A(1)
      LRow = .Cells(Rows.Count, 2).End(xlUp).Row
             
    'Clean Table content
        If Not objListObj.DataBodyRange Is Nothing Then
            objListObj.DataBodyRange.Delete
        End If
        objListObj.ListRows.Add
    
        'Copy Source Range
        .Range(Cells(3, 2), Cells(LRow, 6)).Copy
        objListObj.ListRows(1).Range(1, 1).PasteSpecial xlPasteValues
        'Remove the animation around the copied cell
        Application.CutCopyMode = False
    End With

End Sub

 

[Guinaba]

Give this a try and if there is no change please answer the questions in my previous post

Sub CopyFromRange()

  Dim wrksht As Worksheet
  Dim objListObj As ListObject
  Dim LRow As Long
 
  Set wrksht = ActiveWorkbook.Worksheets("IBPData1")
  Set objListObj = wrksht.ListObjects("tFcst_1")
 
   With Sheets("IBPData1")
     'Find the last non-blank cell in column A(1)
      LRow = .Cells(Rows.Count, 2).End(xlUp).Row
            
    'Clean Table content
        If Not objListObj.DataBodyRange Is Nothing Then
            objListObj.DataBodyRange.Delete
        End If
        objListObj.ListRows.Add
   
        'Copy Source Range
        .Range(Cells(3, 2), Cells(LRow, 6)).Copy
        objListObj.ListRows(1).Range(1, 1).PasteSpecial xlPasteValues
        'Remove the animation around the copied cell
        Application.CutCopyMode = False
    End With

End Sub

Thanks Alex! It runs a little bit faster

 

[Alex Blakenburg]

Can you try turning off (and that back on at the end) the screenupdating and calculations - refer below.:
Let me know how that goes.

If it is still too slow I think we should look at not deleting the rows in the table but only deleting the rows that exceed the number of rows that you need when you copy in the data.

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ' Rest of Code    


    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True