Код VBA для циклического перемещения по папке файлов .csv, вставки данных в шаблон xlsx и сохранения в формате .xlsx

Question

VBA-код не перебирает папку .csv

Приведенный ниже код выполняет нужную мне функцию, но не зацикливается, и было бы хорошо добавить строку для удаления .csv после копирования

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

Код работает для первого файла .csv. Я просто не могу получить цикл для продолжения работы с файлами.Также было бы хорошо добавить строку для удаления .csv, как только они были скопированы

Answer 1

Я думаю, что-то вроде этого, адаптированное для очень быстрого циклического перебора огромных файлов CSVS

ссылка «Microsoft Scripting Runtime» (Добавить с помощью Сервис-> Ссылки из меню VB)

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

Answer 2

1. Работа с объектами. Возможно, вы захотите увидеть Как избежать использования Select в Excel VBA . Объявите объекты для csv и шаблона и работайте с ними.
2. Ваш DIR не работает из-за template = Dir("H:\Case Extracts\template.xlsx", vbNormal), который идет сразу после CSVfilename = Dir(CSVfolder & "*.csv", vbNormal). Это сбрасывается. Поменяйте положение, как показано ниже. Переместите его перед циклом, как упомянуто @AhmedAU.
3. Копировать диапазон только тогда, когда вы готовы вставить. Excel имеет странную привычку очищать буфер обмена. Например, я вставляю сразу после того, как я копирую диапазон.

Это то, что вы пытаетесь? ( Непроверенные )

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