将CSV文件复制到新工作簿

Private Sub CommandButton1_Click()
    CopyCsvFilesToNewWorkbook
End Sub

Sub CopyCsvFilesToNewWorkbook()
     
    ' Select the source folder path.
    Dim sPath As String: sPath = GetSelectedFolderPath
    If Len(sPath) = 0 Then Exit Sub ' dialog canceled
    
    Debug.Print "Folder Path: """ & sPath & """"
    
    ' Write the CSV file paths to an array.
    Dim CsvFilePaths As Variant: CsvFilePaths = FilePathsToArray(sPath, "*.csv")
    If IsEmpty(CsvFilePaths) Then Exit Sub ' no files found
    
    Debug.Print "CSV File Paths"
    Debug.Print Join(CsvFilePaths, vbLf)
    
    ' Copy the CSV files to a new workbook.
    Dim dwb As Workbook: Set dwb = CsvFilesToNewWorkbook(CsvFilePaths)
    If dwb Is Nothing Then Exit Sub
    
    Debug.Print "The new workbook '" & dwb.Name & "' contains " _
        & dwb.Worksheets.Count & " worksheets."
    
    ' Continue with saving the workbook... 'dwb.SaveAs...'
    
End Sub

Function GetSelectedFolderPath( _
    Optional ByVal InitialFolderPath As String = "", _
    Optional ByVal DialogTitle As String = "Browse", _
    Optional ByVal DialogButtonName As String = "OK") _
As String
    
    Dim FolderPath As String
    Dim Canceled As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = DialogTitle
        .ButtonName = DialogButtonName
        Dim pSep As String: pSep = Application.PathSeparator
        If Len(InitialFolderPath) > 0 Then
            FolderPath = InitialFolderPath
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
            .InitialFileName = FolderPath
        End If
        If .Show Then
            FolderPath = .SelectedItems(1)
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
        Else
            Canceled = True
        End If
    End With
    
    If Canceled Then
        MsgBox "Dialog canceled.", vbExclamation, "GetSelectedFolderPath"
        Exit Function
    End If

    GetSelectedFolderPath = FolderPath

End Function

Function FilePathsToArray( _
    ByVal SourceFolderPath As String, _
    Optional ByVal FilePattern As String = "*.*") _
As Variant
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(SourceFolderPath)
    Dim LCaseFilePattern As String: LCaseFilePattern = LCase(FilePattern)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim fsoFile As Object
    Dim FilePath As String
    
    For Each fsoFile In fsoFolder.Files
        FilePath = fsoFile.Path
        If LCase(FilePath) Like LCaseFilePattern Then
            dict(FilePath) = Empty
        End If
    Next fsoFile
    
    If dict.Count = 0 Then
        MsgBox "No files found.", vbExclamation
        Exit Function
    End If
    
    FilePathsToArray = dict.Keys

End Function

' This method is written as a function
' to return a reference to the new workbook.
Function CsvFilesToNewWorkbook( _
    ByVal CsvFilePaths As Variant) _
As Workbook
' It is assumed that none of the CSV files are open in the current application
' i.e. if a file is open, modified but not saved, this procedure
' will copy the modified file but will also close it without saving the changes.
' If a file is open in another application, it might not get copied.

    Application.ScreenUpdating = False

    Dim swb As Workbook
    Dim sws As Worksheet
    Dim dwb As Workbook
    Dim n As Long
    Dim FilesCount As Long
    Dim FilePath As String
    
    For n = LBound(CsvFilePaths) To UBound(CsvFilePaths)
        FilePath = CsvFilePaths(n)
        On Error Resume Next
            Set swb = Workbooks.Open(FilePath, True, True)
        On Error GoTo 0
        If Not swb Is Nothing Then ' workbook is open
            Set sws = swb.Worksheets(1) ' the one and only
            FilesCount = FilesCount + 1
            If FilesCount = 1 Then ' the first source workbook
                ' Copy the worksheet to a new workbook.
                sws.Copy ' creates a new single-worksheet workbook
                ' Reference this new workbook, the destination workbook.
                Set dwb = Workbooks(Workbooks.Count)
            Else ' all source workbooks but the first
                ' Copy the source worksheet to the destination workbook.
                sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
            End If
            swb.Close SaveChanges:=False
            Set swb = Nothing ' reset
        'Else ' workbook is not open; do nothing
        End If
    Next n
    
    If Not dwb Is Nothing Then
        'dwb.Saved = True ' to easily close while testing
        Set CsvFilesToNewWorkbook = dwb
    End If
    
    Application.ScreenUpdating = True
    
    'MsgBox "Copied " & FilesCount & "(" & n & ")" & " CSV file" _
        & IIf(FilesCount = 1, "", "s") & " to a new workbook.", _
        IIf(FilesCount = 0, vbExclamation, vbInformation), _
        "CsvFilesToNewWorkbook"
    
End Function

字符串