Copying range to table

[Guinaba]

Hi guys,

I am using the below code to copy a range to a table, however some dates are incorrectly converting from dd/mm/yyyy to mm/dd/yyyyy:

Range (Correct date)	Table (incorrect date)
01/07/2024	07/01/2024
05/08/2024	08/05/2024
12/08/2024	08/12/2024

Is there any way to avoid that happening?

Sub Data_Array_Set_IBPData_1(vDtaHdr() As Variant, vDtaBdy() As Variant)

   Dim wrksht As Worksheet
   Dim objListObj As ListObject
   Dim vArray As Variant

  '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, 8))
        vArray = .Rows(1)
        vDtaHdr = vArray
        vArray = .Offset(1, 0).Resize(-1 + .Rows.Count)
        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

 

[Alex Blakenburg]

It looks like your data might be inconsistently text or date. Try the below which should handle both scenarios:

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, 8))
        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

 

[Guinaba]

It looks like your data might be inconsistently text or date. Try the below which should handle both scenarios:

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, 8))
        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

Hey @Alex Blakenburg,

That is awesome!! Now it is working perfeclty!! Thanks a lot for your help and patience with me

 

[Alex Blakenburg]

No worries. Glad I could help.