VBA procedure changing the date format

[Guinaba]

Hi guys,

The code below is copying the data from a table (listobject) and saving in another file (csv), however not sure why the first colum which is date format (dd/mm/yyyy) is getting changed to mm/dd/yyyy when the sub is writing in the csv file. Is there a way to avoid that?

Cheers

Sub PlannedOrdersHistory()

    Application.ScreenUpdating = False

    Dim CurrDate As Date
    CurrDate = Date
    Dim CurrFileName As String
    CurrFileName = Format(CurrDate, "yyyymmdd") & "_ED_Fcst_VS_Planned_Orders_V10" & ".XLSM"
    Dim Wb1 As Workbook: Set Wb1 = Workbooks(CurrFileName)
    Dim Wb2 As Workbook: Set Wb2 = Workbooks.Open("C:\Users\gnassifb\OneDrive - Lion Pty Ltd\Documents\ED\ED Planned Orders\ED_Planned_Orders_History_1.csv")
    Dim LRow As Integer
    Dim SearchString As String
    Dim SearchRange As Range
    SearchString = CurrDate

    With Wb2.Worksheets("ED_Planned_Orders_History_1")
      'Find the last non-blank cell in column A(1)
       LRow = .Cells(Rows.Count, 1).End(xlUp).Row
    End With
   
    'Check if the data is already copied
    Set SearchRange = Range("A2:A" & LRow).Find(SearchString, LookIn:=xlValues, lookat:=xlWhole)
    If SearchRange Is Nothing Then
        Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Copy _
        Destination:=Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A" & LRow)
    Else
        MsgBox "Data is already copied", vbExclamation: Exit Sub
   
    End If
 
    'Wb2.Close SaveChanges:=True
   
 End Sub

 

[Biz]

Does code below help?

Sub PlannedOrdersHistory()
    Application.ScreenUpdating = False

    Dim CurrDate As Date
    CurrDate = Date
    Dim CurrFileName As String
    CurrFileName = Format(CurrDate, "yyyymmdd") & "_ED_Fcst_VS_Planned_Orders_V10" & ".XLSM"
    Dim Wb1 As Workbook: Set Wb1 = Workbooks(CurrFileName)
    Dim Wb2 As Workbook: Set Wb2 = Workbooks.Open("C:\Users\gnassifb\OneDrive - Lion Pty Ltd\Documents\ED\ED Planned Orders\ED_Planned_Orders_History_1.csv")
    Dim LRow As Long
    Dim SearchString As String
    Dim SearchRange As Range
    SearchString = Format(CurrDate, "mm/dd/yyyy")

    With Wb2.Worksheets("ED_Planned_Orders_History_1")
        'Find the last non-blank cell in column A(1)
        LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    'Check if the data is already copied
    Set SearchRange = Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A2:A" & LRow).Find(SearchString, LookIn:=xlValues, LookAt:=xlWhole)
    If SearchRange Is Nothing Then
        Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Copy
        Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A" & LRow + 1).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
        Application.CutCopyMode = False
        
        ' Convert the pasted values to text using Text-to-Columns
        Dim PasteRange As Range
        Set PasteRange = Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A" & LRow + 1).Resize(Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Rows.Count, _
                                                                                               Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Columns.Count)
        PasteRange.TextToColumns Destination:=PasteRange, DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2)
    Else
        MsgBox "Data is already copied", vbExclamation
        Exit Sub
    End If

    'Wb2.Close SaveChanges:=True

    Application.ScreenUpdating = True
End Sub

 

[Guinaba]

Hey @Biz,

Thanks for sharing the code, I am getting the following error when running it:

FAILING HERE->> PasteRange.TextToColumns Destination:=PasteRange, DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2)

Cheers,

 

[kevin9999]

Just a thought in passing, with your existing code - which I assume is working OK except for the date format issue (although I would have thought the target cell to paste should have been LRow + 1 ) - try changing this bit:

Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Copy _
Destination:=Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A" & LRow)

with this (UNTESTED):

Wb1.Worksheets("EDPlannedOrders").ListObjects("tPlannedOrdersWeekly").DataBodyRange.Copy
Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A" & LRow).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False

and see if that makes any difference.

 

[Guinaba]

Thanks @kevin9999! That works perfectly! Including the missing point about the Range("A" & LRow+1). Can I ask you one last question

I have a validation line in the code, searching for the date, i.e. if today's date is there the code should not run, however is not working. Should I used a loop instead?

'Check if the data is already copied
Set SearchRange = Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A2:A" & LRow).Find(SearchString, LookIn:=xlValues, LookAt:=xlWhole)
If SearchRange Is Nothing Then

 

[kevin9999]

One problem could be your line:

Set SearchRange = Range("A2:A" & LRow)...

Where you haven't qualified the sheet the range is in - therefore it will apply to whatever the active sheet is when you run the code. I would set the destination sheet, something like:

Dim WsDest as Worksheet
Set WsDest = Wb2.Worksheets("ED_Planned_Orders_History_1")

Then using that variable, I would do something like:

If WorksheetFunction.Max(WsDest.Range("A:A")) <> Date Then

instead of:

Set SearchRange = Wb2.Worksheets("ED_Planned_Orders_History_1").Range("A2:A" & LRow).Find(SearchString, LookIn:=xlValues, LookAt:=xlWhole)
If SearchRange Is Nothing Then

 

[Guinaba]

Awesome! Thanks @kevin9999

 

[kevin9999]

Awesome! Thanks @kevin9999

Happy to help, and thanks for the feedback