VBA code to loop through folder of .csv files, paste data into a xlsx template and save as .xlsx

Question

VBA code not looping through the folder of .csv's

The code below is doing the function I need but is not looping and it would be good to add a line to delete the .csv's once copied

Option Explicit

Private Sub SaveAs_Files_in_Folder()

    Dim CSVfolder As String, XLSfolder As String
    Dim CSVfilename As String, XLSfilename As String
    Dim template As String
    Dim wb As Workbook
    Dim wbm As Workbook 'The template I want the data pasted into


    Dim n As Long


    CSVfolder = "H:\Case Extracts\input"    'Folder I have the csv's go
    XLSfolder = "H:\Case Extracts\output"    'Folder for the xlsx output


    If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
    If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"

    n = 0

    CSVfilename = Dir(CSVfolder & "*.csv", vbNormal)

    template = Dir("H:\Case Extracts\template.xlsx", vbNormal) 

    While Len(CSVfilename) <> 0
        n = n + 1

        Set wb = Workbooks.Open(CSVfolder & CSVfilename)
        Range("A1:M400").Select
        Selection.Copy


        Set wbm = Workbooks.Open(template, , , , "Password") 'The template has a password          
        With wbm
                Worksheets("Sheet2").Activate
                Sheets("Sheet2").Cells.Select
                Range("A1:M400").PasteSpecial  
                Worksheets("Sheet1").Activate
                Sheets("Sheet1").Range("A1").Select

                wbm.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
                wbm.Close
         End With
         With wb
                .Close False
         End With

         CSVfilename = Dir()  

    Wend

End Sub

The code works for the first .csv file I just can't get the loop to keep going through the files. It would also be good to add a line to delete the .csv's once they have been copied

Answer 1

1. Work with objects. You may want to see How to avoid using Select in Excel VBA. Declare objects for both the csv and template and work with them.
2. Your DIR is not working because of template = Dir("H:\Case Extracts\template.xlsx", vbNormal) which is right after CSVfilename = Dir(CSVfolder & "*.csv", vbNormal). It is getting reset. Reverse the position as shown below. Move it before the loop as @AhmedAU mentioned.
3. Copy the range only when you are ready to paste. Excel has an uncanny habit of clearing the clipboard. For example, I am pasting right after I cam copying the range.

Is this what you are trying? (Untested)

Option Explicit

Private Sub SaveAs_Files_in_Folder()
    Dim CSVfolder As String, XLSfolder As String
    Dim CSVfilename As String, XLSfilename As String
    Dim wbTemplate As Workbook, wbCsv As Workbook
    Dim wsTemplate As Worksheet, wsCsv As Worksheet

    CSVfolder = "H:\Case Extracts\input"    '<~~ Csv Folder
    XLSfolder = "H:\Case Extracts\output"   '<~~ For xlsx output

    If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
    If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"

    XLSfilename = Dir("H:\Case Extracts\template.xlsx", vbNormal)
    CSVfilename = Dir(CSVfolder & "*.csv")

    Do While Len(CSVfilename) > 0
        '~~> Open Csv File
        Set wbCsv = Workbooks.Open(CSVfolder & CSVfilename)
        Set wsCsv = wbCsv.Sheets(1)

        '~~> Open Template file
        Set wbTemplate = Workbooks.Open(XLSfolder & XLSfilename, , , , "Password")
        '~~> Change this to relevant sheet
        Set wsTemplate = wbTemplate.Sheets("Sheet1")

        '~~> Copy and paste
        wsCsv.Range("A1:M400").Copy
        wsTemplate.Range("A1").PasteSpecial xlPasteValues

        '~~> Save file
        wbTemplate.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook

        '~~> Close files
        wbTemplate.Close (False)
        wbCsv.Close (False)

        '~~> Get next file
        CSVfilename = Dir
    Loop

    '~~> Clear clipboard
    Application.CutCopyMode = False
End Sub

Answer 2

I think must be something like this, adapted to very fast looping through huge of csvs files

reference “Microsoft Scripting Runtime” (Add using Tools->References from the VB menu)

Sub SaveAs_Files_in_Folder()
Dim myDict As Dictionary, wb As Workbook, eachLineArr As Variant
    Set myDict = CreateObject("Scripting.Dictionary")
    CSVfolder = "H:\Case Extracts\input\"
    XLSfolder = "H:\Case Extracts\output\"
    Template = ThisWorkbook.path & "\template.xlsx"
    fileMask = "*.csv"
    csvSeparator = ";"
    csvLineBreaks = vbLf ' or vbCrLf
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .EnableEvents = False
    .Calculation = xlManual
    '.Visible = False ' uncomment to hide templates flashing
End With
    LookupName = CSVfolder & fileMask
        Results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & LookupName & Chr(34) & " /S /B /A:-D").StdOut.ReadAll
        filesList = Split(Results, vbCrLf)
            For fileNr = LBound(filesList) To UBound(filesList) - 1
                csvLinesArr = Split(GetCsvFData(filesList(fileNr)), csvLineBreaks) ' read each csv to array
                ArrSize = UBound(Split(csvLinesArr(lineNr), csvSeparator))

                For lineNr = LBound(csvLinesArr) To UBound(csvLinesArr)
                    If csvLinesArr(lineNr) <> "" Then
                        eachLineArr = Split(csvLinesArr(lineNr), csvSeparator) ' read each line to array
                        ReDim Preserve eachLineArr(ArrSize) ' to set first line columns count to whoole array size
                        myDict.Add Dir(filesList(fileNr)) & lineNr, eachLineArr ' put all lines into dictionary object
                    End If
                Next lineNr
                Set wb = Workbooks.Open(Template, , , , "Password")
                    wb.Worksheets("Sheet1").[a1].Resize(myDict.Count, ArrSize) = TransposeArrays1D(myDict.Items)
                      Set fso = CreateObject("Scripting.FileSystemObject")
                         csvName = fso.GetBaseName(filesList(fileNr))
                      Set fso = nothing
                    wb.SaveAs FileName:=XLSfolder & csvName & ".xlsx"
                    wb.Close
                Set wb = Nothing
            Next fileNr
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
    .Calculation = xlManual
    .Visible = True
End With
End Sub

Function GetCsvFData(ByVal filePath As String) As Variant
    Dim MyData As String, strData() As String
    Open filePath For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    GetCsvFData = MyData
End Function

Function TransposeArrays1D(ByVal arr As Variant) As Variant
    Dim tempArray As Variant
     ReDim tempArray(LBound(arr, 1) To UBound(arr, 1), LBound(arr(0)) To UBound(arr(0)))
        For y = LBound(arr, 1) To UBound(arr, 1)
            For x = LBound(arr(0)) To UBound(arr(0))
                tempArray(y, x) = arr(y)(x)
            Next x
        Next y
     TransposeArrays1D = tempArray
End Function