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

使用对象。您可能需要查看How to avoid using Select in Excel VBA。为csv和模板声明对象并使用它们。
您的DIR无法正常运行，因为template = Dir("H:\Case Extracts\template.xlsx", vbNormal)就在CSVfilename = Dir(CSVfolder & "*.csv", vbNormal)之后。它正在重置。如下所示反转位置。如@AhmedAU所述将其移到循环之前。
仅在准备粘贴时复制范围。 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

Answer 2

我认为一定是这样的，适合于快速地循环浏览大量的csvs文件

参考“ Microsoft脚本运行时”（使用工具-> 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

VBA代码遍历.csv文件的文件夹，将数据粘贴到xlsx模板中，然后另存为.xlsx

2 个答案: