Modify Column format before saving as csv file

[WascoWarrior]

I have a button in a XLSM spreadsheet that lets the user copy the data to a new sheet and save as a CSV file.

What I need to do before saving as a csv file, is modify the format of 2 columns-dates (currently set as text with data represented as mm/dd/yy and change the column so the data is saved as mmddyy (remove the slashes) before saving as a CSV file. How can this be accomplished using VBA. I don't want the user to manually modify the fields.
Sub CmdUploadIFS_Click()
'***************************************************************************************
'*** Save Spreadsheet as csv ***
'***************************************************************************************

Dim MyPath As String
Dim MyFileName As String
Dim FullPath As String
Dim WB1 As Workbook, WB2 As Workbook
Dim rng As Range
Dim todaydate As Date

MyPath = "C:\UPLOAD\UPLOADPO"
Set WB1 = ActiveWorkbook

On Error Resume Next
Set rng = Range("A3:K9999")
If rng Is Nothing Then Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
rng.Copy

Set WB2 = Application.Workbooks.Add(1)
WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
todaydate = Now()
MyFileName = "UPLOADPO_" & Format(todaydate, "yyyymmdd_hhmmss")
FullPath = MyPath & "\" & MyFileName

Application.DisplayAlerts = False
If MsgBox("Data will be copied to: " & MyPath & "\" & MyFileName & vbCrLf & _
"Continue?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If

If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
With WB2
.SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=True
.Close False
End With
Application.DisplayAlerts = True
End Sub

 

[Jeffrey Mahoney]

Please try this.

Sub CmdUploadIFS_Click()
'***************************************************************************************
'*** Save Spreadsheet as csv ***
'***************************************************************************************

  Dim MyPath As String
  Dim MyFileName As String
  Dim FullPath As String
  Dim WB1 As Workbook, WB2 As Workbook
  Dim rng As Range
  Dim todaydate As Date
  
  MyPath = "C:\UPLOAD\UPLOADPO"
  Set WB1 = ActiveWorkbook
  
  On Error Resume Next
  Set rng = Range("A3:K9999")
  If rng Is Nothing Then Exit Sub
  On Error GoTo 0
  Application.ScreenUpdating = False
  rng.Copy
  
  Application.Calculation = xlCalculationManual
  
  Set WB2 = Application.Workbooks.Add(1)
  WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
  Set Sht = ActiveSheet
  
  Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(slup)) 'Column F
  rng.NumberFormat = "@"
  
  For Each Cel In rng
    Cel.Value = Replace(Cel.Value, "/", "")
  Next Cel
  
  Set rng = Sht.Range(Range("G1"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(slup)) 'Column F
  rng.NumberFormat = "@"
  
  For Each Cel In rng
    Cel.Value = Replace(Cel.Value, "/", "")
  Next Cel
  
  
  
  todaydate = Now()
  MyFileName = "UPLOADPO_" & Format(todaydate, "yyyymmdd_hhmmss")
  FullPath = MyPath & "\" & MyFileName
  
  Application.DisplayAlerts = False
  If MsgBox("Data will be copied to: " & MyPath & "\" & MyFileName & vbCrLf & _
  "Continue?", vbQuestion + vbYesNo) <> vbYes Then
    Exit Sub
  End If
  
  If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
  With WB2
    .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=True
    .Close False
  End With
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[WascoWarrior]

I tried inserting your modifications, but it is failing on the:
Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlup)).
I think (slup) was a typo so I changed it.
I'm getting Run-time error 1004 Application-defined or object-defined error.
I also moved the Application.Calculation = xlCalculationManual line after the WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues line because it was erroring out with an X400.
Any suggestions?

 

[Jeffrey Mahoney]

Good catch on "slup". There was a second one. I fixed those in the version below.

What line is giving you the error?

The purpose for 'Application.Calculation = xlCalculationManual' is to stop Excel from recalculating. It would defeat the purpose if you moved it below the line you stated.

Make sure your table begins on row 1. If not, change these lines:
Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlUp)) 'Column F
Set rng = Sht.Range(Range("G1"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(xlUp)) 'Column F
TO:
Set rng = Sht.Range(Range("F2"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlUp)) 'Column F
Set rng = Sht.Range(Range("G2"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(xlUp)) 'Column F
or whatever row the table begins

Sub CmdUploadIFS_Click()
'***************************************************************************************
'*** Save Spreadsheet as csv ***
'***************************************************************************************

  Dim MyPath As String
  Dim MyFileName As String
  Dim FullPath As String
  Dim WB1 As Workbook, WB2 As Workbook
  Dim rng As Range
  Dim todaydate As Date
  
  MyPath = "C:\UPLOAD\UPLOADPO"
  Set WB1 = ActiveWorkbook
  
  On Error Resume Next
  Set rng = Range("A3:K9999")
  If rng Is Nothing Then Exit Sub
  On Error GoTo 0
  Application.ScreenUpdating = False
  rng.Copy
  
  Application.Calculation = xlCalculationManual
  
  Set WB2 = Application.Workbooks.Add(1)
  WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
  Set Sht = ActiveSheet
  
  Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlUp)) 'Column F
  rng.NumberFormat = "@"
  
  For Each Cel In rng
    Cel.Value = Replace(Cel.Value, "/", "")
  Next Cel
  
  Set rng = Sht.Range(Range("G1"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(xlUp)) 'Column F
  rng.NumberFormat = "@"
  
  For Each Cel In rng
    Cel.Value = Replace(Cel.Value, "/", "")
  Next Cel
  
  
  
  todaydate = Now()
  MyFileName = "UPLOADPO_" & Format(todaydate, "yyyymmdd_hhmmss")
  FullPath = MyPath & "\" & MyFileName
  
  Application.DisplayAlerts = False
  If MsgBox("Data will be copied to: " & MyPath & "\" & MyFileName & vbCrLf & _
  "Continue?", vbQuestion + vbYesNo) <> vbYes Then
    Exit Sub
  End If
  
  If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
  With WB2
    .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=True
    .Close False
  End With
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[WascoWarrior]

When I execute the code exactly as coded, it creates the new sheet with no data copied and I get a X400 error message. When I step thru in Debug it fails on this line now:
WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
The only new code at this point now is the:
Application.Calculation = xlCalculationManual

FYI: Yes, the data gets loaded into the new sheet starting in cell A1.

 

[Jeffrey Mahoney]

Ok, I was able to fully test this macro and it worked

Book4 20240522.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1
2	Upload Purchase order
3	Company	PO Number	Vendor Number	Item	Quantity	Promise Date MM/DD/YY	Due Date MM/DD/YY	Planner	Ship Via	Buyer	Warehouse	Error Messages
4	One	789456	123789	1	10	5/31/2024	6/15/2024	Him	Fedex	He	WH12	None
5	Two	789460	123799	2	20	6/5/2024	6/20/2024	Us	UPS	They	WH30	None
6	Three	789464	123809	3	30	6/10/2024	6/25/2024	Them	USPS	We	WH50	None
Sheet1

Cell Formulas
Range	Formula
B5:B6	B5	=B4+4
C5:C6	C5	=C4+10
F5:G6	F5	=F4+5

Sub CmdUploadIFS_Click()
'***************************************************************************************
'*** Save Spreadsheet as csv ***
'***************************************************************************************

  Dim MyPath As String
  Dim MyFileName As String
  Dim FullPath As String
  Dim WB1 As Workbook, WB2 As Workbook
  Dim rng As Range
  Dim todaydate As Date
  Dim Sht As Worksheet
  Dim Cel As Range
  Dim aStr As String
  Dim Dt As Date
  
  MyPath = "C:\UPLOAD\UPLOADPO"
  Set WB1 = ActiveWorkbook
  
  On Error Resume Next
  Set rng = Range("A3:K9999")
  If rng Is Nothing Then Exit Sub
  On Error GoTo 0
  Application.ScreenUpdating = False
  
  
  Application.Calculation = xlCalculationManual
  
  Set WB2 = Application.Workbooks.Add(1)
  rng.Copy
  WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
  Set Sht = ActiveSheet
  
  
  Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlUp)) 'Column F
  rng.NumberFormat = "mm/dd/yyyy"
  'rng.NumberFormat = "@"
  
  For Each Cel In rng
    If IsDate(Cel) Then
      Dt = Cel.Value
      Cel.NumberFormat = "@"
      Cel.Value = Format(Dt, "mmddyy")
    End If
  Next Cel
  
  Set rng = Sht.Range(Range("G1"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(xlUp)) 'Column F
  rng.NumberFormat = "mm/dd/yyyy"
  'rng.NumberFormat = "@"
  
  For Each Cel In rng
    If IsDate(Cel) Then
      Dt = Cel.Value
      Cel.NumberFormat = "@"
      Cel.Value = Format(Dt, "mmddyy")
    End If
  Next Cel
  
  
  
  todaydate = Now()
  MyFileName = "UPLOADPO_" & Format(todaydate, "yyyymmdd_hhmmss")
  FullPath = MyPath & "\" & MyFileName
  
  Application.DisplayAlerts = False
  If MsgBox("Data will be copied to: " & MyPath & "\" & MyFileName & vbCrLf & _
  "Continue?", vbQuestion + vbYesNo) <> vbYes Then
    Exit Sub
  End If
  
  If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
  With WB2
    .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=True
    .Close False
  End With
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[WascoWarrior]

Still getting the X400 error
It gets this far and stops.
I'm not sure what the issue is.
I will try creating a new sheet and insert just this code and see if I get the same result.

 

[Jeffrey Mahoney]

I feel like there may be an addin that is conflicting

Try adding Application.EnableEvents = False at the beginning of the macro and the opposing one at the end

 

[Alex Blakenburg]

Ok, I was able to fully test this macro and it worked

Hello Jeff, does fully testing it mean that you ran it from a button ?
In the thread here the issue was that code was in a sheet module (as is the case when running from a button) and not a normal module.
I thought that having Range unqualified inside the brackets was a likely candidate for that issue.

@WascoWarriorthis line appears in 2 places 1 for column F and 1 for column G.
What happens if you change them both from this format:

' Col F
Set rng = Sht.Range(Range("F1"), Sht.Cells(Sht.Cells.Rows.Count, 6).End(xlUp)) 'Column F
' Col G
Set rng = Sht.Range(Range("G1"), Sht.Cells(Sht.Cells.Rows.Count, 7).End(xlUp)) 'Column G

to this format:

' Col F
  With Sht
    Set rng = .Range(.Range("F1"), .Cells(.Cells.Rows.Count, 6).End(xlUp)) 'Column F
  End With

' Col G
  With Sht
    Set rng = .Range(.Range("G1"), .Cells(.Cells.Rows.Count, 7).End(xlUp)) 'Column G
  End With

 

[WascoWarrior]

I made the suggested change in the code and it worked beautifully! Thank you both for the solution. Teamwork makes VBA work!