Tunning a VBA macro

[Guinaba]

Hi guys,

Is there a way to make this code running faster? This macro is running on 700,000 rows and converting the range into a table.

Sub Data_Array_Set_IBPData_1(vDtaHdr() As Variant, vDtaBdy() As Variant)
   Dim wrksht As Worksheet
   Dim objListObj As ListObject
   Dim vArray As Variant
   
   Dim LRow As Long
   Dim i As Long

  'Find the last non-blank cell in column A(1)
   LRow = ThisWorkbook.Worksheets("IBP Data").Cells(Rows.Count, 2).End(xlUp).Row
  
   With ThisWorkbook.Worksheets("IBP Data").Range(ThisWorkbook.Worksheets("IBP Data").Cells(2, 1), ThisWorkbook.Worksheets("IBP Data").Cells(LRow, 9))
        vArray = .Rows(1)
        vDtaHdr = vArray
        vArray = .Offset(1, 0).Resize(-1 + .Rows.Count)
        For i = 1 To UBound(vArray)
            If IsDate(vArray(i, 1)) Then
                vArray(i, 1) = CDate(vArray(i, 1))
            End If
        Next i
        vDtaBdy = vArray
  End With
End Sub
  
Sub IBPData_1()

    Dim MyTable As ListObject
    Dim vDtaHdr() As Variant, vDtaBdy() As Variant
    Dim lRowsAdj As Long
        
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Set MyTable = ThisWorkbook.Worksheets("IBP Data").ListObjects("tFcst_1") 'Change as required

    Call Data_Array_Set_IBPData_1(vDtaHdr, vDtaBdy)

    With MyTable.DataBodyRange
        Rem Get Number of Rows to Adjust
        lRowsAdj = 1 + UBound(vDtaBdy, 1) - LBound(vDtaBdy, 1) - .Rows.Count

        Rem Resize ListObject
        If lRowsAdj < 0 Then
            Rem Delete Rows
            .Rows(1).Resize(Abs(lRowsAdj)).Delete xlShiftUp

        ElseIf lRowsAdj > 0 Then
            Rem Insert Rows
            .Rows(1).Resize(lRowsAdj).Insert Shift:=xlDown

    End If: End With

    Rem Overwrite Table with New Data
    MyTable.HeaderRowRange.Value = vDtaHdr
    MyTable.DataBodyRange.Value = vDtaBdy
      
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   
   MsgBox "Table has been refreshed", vbInformation
   
End Sub

 

[Skyybot]

Test this on a COPY of your Workbook and see if it produces the expected results.

Option Explicit

Sub ConvertToTable()
Dim wb As Workbook, sht As Worksheet, rng As Range, lRow As Long
Set wb = ThisWorkbook
Set sht = wb.Sheets("IPB Data")
lRow = wb.sht.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = Range(sht.Cells(1, 1), sht.Cells(lRow, 9))
sht.ListObjects.Add xlSrcRange, rng, XlListObjectHasHeaders:=xlYes, Destination:=sht.Cells(1, 1)
End Sub