CODEWITHSUNDEEP
excelvbacsv
Pepe S
Pepe S

Reputation: 65

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

I've VBA code to convert a folder of xls files to csv.

I'd also like to convert the date formatting in column H of each file to "MMM-YY".

I tried including another loop to format the dates.

I'd 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

Upvotes: 0

Views: 60

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

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

Upvotes: 1

Related Questions