How to include batch date formatting in xls to csv conversion with VBA-CodePudding

I've got a VBA script to convert a folder of xls files to csv. At the moment that works fine, but I'd also like to convert the date formatting in column H of each file to "MMM-YY".

The code I currently have for converting to CSV is below. I've tried messing around with including another loop to format the dates but it's not working and a bit messy. I'll include that below also but don't think I'm going about it the correct way.

I'd basically like each xls to be saved as a CSV and then convert the formatting of column H in the CSV to "MMM-YY" formatting. The script below allows the user to select the folder with the files to convert and the folder to save these files in. I'd like that to be the maximum user input if possible.

XLS to CSV script:

Sub WorkbooksSaveAsCsvToFolder()


Dim xObjWB As Workbook

Dim xObjWS As Worksheet

Dim xStrEFPath As String

Dim xStrEFFile As String

Dim xObjFD As FileDialog

Dim xObjSFD As FileDialog

Dim xStrSPath As String

Dim xStrCSVFName As String

Dim xS  As String

    Application.ScreenUpdating = False

    Application.EnableEvents = False

    Application.Calculation = xlCalculationManual

    Application.DisplayAlerts = False

    On Error Resume Next

Set xObjFD = Application.FileDialog(msoFileDialogFolderPicker)

    xObjFD.AllowMultiSelect = False

    xObjFD.Title = "Select a folder which contains Excel files"

    If xObjFD.Show <> -1 Then Exit Sub

    xStrEFPath = xObjFD.SelectedItems(1) & "\"

    Set xObjSFD = Application.FileDialog(msoFileDialogFolderPicker)

 
    xObjSFD.AllowMultiSelect = False

    xObjSFD.Title = "Select a folder to locate CSV files"

    If xObjSFD.Show <> -1 Then Exit Sub

    xStrSPath = xObjSFD.SelectedItems(1) & "\"


    xStrEFFile = Dir(xStrEFPath & "*.xls*")


    Do While xStrEFFile <> ""

       xS = xStrEFPath & xStrEFFile

        Set xObjWB = Application.Workbooks.Open(xS)

        xStrCSVFName = xStrSPath & Left(xStrEFFile, InStr(1, xStrEFFile, ".") - 1) & ".csv"

        xObjWB.SaveAs Filename:=xStrCSVFName, FileFormat:=xlCSV

        xObjWB.Close savechanges:=False

        xStrEFFile = Dir

  Loop

    Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub

Attempt at converting XLS to CSV and formatting date:

Sub WorkbooksSaveAsCsvToFolder()


Dim xObjWB As Workbook

Dim xObjWS As Worksheet

Dim xStrEFPath As String

Dim xStrEFFile As String

Dim xStrSFile As String

Dim xObjFD As FileDialog

Dim xObjSFD As FileDialog

Dim xStrSPath As String

Dim xStrCSVFName As String

Dim xS  As String

    Application.ScreenUpdating = False

    Application.EnableEvents = False

    Application.Calculation = xlCalculationManual

    Application.DisplayAlerts = False

    On Error Resume Next

Set xObjFD = Application.FileDialog(msoFileDialogFolderPicker)

    xObjFD.AllowMultiSelect = False

    xObjFD.Title = "Select a folder which contains Excel files"

    If xObjFD.Show <> -1 Then Exit Sub

    xStrEFPath = xObjFD.SelectedItems(1) & "\"

    Set xObjSFD = Application.FileDialog(msoFileDialogFolderPicker)

 
    xObjSFD.AllowMultiSelect = False

    xObjSFD.Title = "Select a folder to locate CSV files"

    If xObjSFD.Show <> -1 Then Exit Sub

    xStrSPath = xObjSFD.SelectedItems(1) & "\"


    xStrEFFile = Dir(xStrEFPath & "*.xls*")


    Do While xStrEFFile <> ""

       xS = xStrEFPath & xStrEFFile
        
        Set xObjWB = Application.Workbooks.Open(xS)
        
        xStrCSVFName = xStrSPath & Left(xStrEFFile, InStr(1, xStrEFFile, ".") - 1) & ".csv"

        xObjWB.SaveAs Filename:=xStrCSVFName, FileFormat:=xlCSV

        xObjWB.Close SaveChanges:=False
        
        xStrEFFile = Dir
        
      Loop
       
    xStrSFile = Dir(xStrSPath & "*.csv*")    

      Do While xStrSFile <> ""    
      
      xStrCSVFName = xStrSPath & Left(xStrSFile, InStr(1, xStrSFile, ".") - 1) & ".csv"
      
       xD = xStrSPath & xStrCSVFName
       
        Set xStrWB = Application.Workbooks.Open(xD)
        
        xD.Worksheets(1).Columns("H:H").NumberFormat = "mmm-yy"
        
        xStrWB.Close SaveChanges:=True
      
        xStrSFile = Dir

  Loop
  
  

    Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub

Any help here would be greatly appreciated!

Thanks!

CodePudding user response：

Please, try the next adapted code. No need of another iteration between files:

Sub WorkbooksSaveAsCsvToFolder()
  Dim xObjWB As Workbook, xObjWS As Worksheet
  Dim xStrEFPath As String, xStrEFFile As String, xStrSFile As String

  Dim xObjFD As FileDialog, xObjSFD As FileDialog
  Dim xStrSPath As String, xStrCSVFName As String, xS As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    'On Error Resume Next

   Set xObjFD = Application.FileDialog(msoFileDialogFolderPicker)

    xObjFD.AllowMultiSelect = False

    xObjFD.Title = "Select a folder which contains Excel files"

    If xObjFD.Show <> -1 Then Exit Sub

    xStrEFPath = xObjFD.SelectedItems(1) & "\"
    

    Set xObjSFD = Application.FileDialog(msoFileDialogFolderPicker)

    xObjSFD.AllowMultiSelect = False

    xObjSFD.Title = "Select a folder to locate CSV files"

    If xObjSFD.Show <> -1 Then Exit Sub

    xStrSPath = xObjSFD.SelectedItems(1) & "\"


    xStrEFFile = Dir(xStrEFPath & "*.xls*")


    Dim arr, lastR As Long
    Do While xStrEFFile <> ""

           xS = xStrEFPath & xStrEFFile
            
            Set xObjWB = Application.Workbooks.Open(xS)
           lastR = xObjWB.Worksheets(1).Range("H" & rows.count).End(xlUp).row
           With xObjWB.Worksheets(1).Columns("H1:H" & lastR)
                arr = .Value2
                arr = DateAsText(arr)
                .NumberFormat = "@"
                .Value = arr
           End With
            
            xStrCSVFName = xStrSPath & left(xStrEFFile, InStr(1, xStrEFFile, ".") - 1) & ".csv"
    
            xObjWB.saveas fileName:=xStrCSVFName, FileFormat:=xlCSV
    
            xObjWB.Close SaveChanges:=False
            
            xStrEFFile = Dir
            
    Loop
       
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Function DateAsText(arrD) As String()
     Dim arrTxt() As String, i As Long
     ReDim arrTxt(1 To UBound(arrD), 1 To 1)
     For i = 1 To UBound(arrD)
         arrTxt(i, 1) = CStr(Format(arrD(i, 1), "MMM-YY"))
     Next i
     DateAsText = arrTxt
End Function