将文件夹下所有csv文件里内容拷贝到新的excle文件中

最新推荐文章于 2024-02-09 09:00:00 发布

喂，闭眼

最新推荐文章于 2024-02-09 09:00:00 发布

阅读量174

点赞数

分类专栏： VBA 文章标签： excel powerpoint

本文链接：https://blog.csdn.net/weixin_42117570/article/details/129848886

版权

VBA 专栏收录该内容

5 篇文章 0 订阅

订阅专栏

Sub LoopThroughFiles()
Dim MyFile As String, MyPath As String, MyExtension As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim NewBook As Workbook
    Dim NewSheet As Worksheet
    Dim SheetName As String
    
 
'Prompt the user to select the folder containing the CSV files
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder containing the CSV files"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "No folder selected. The macro will now exit.", vbCritical, "Error"
            Exit Sub
        End If
        MyPath = .SelectedItems(1) & "\"
    End With
    
    'Set the file extension to CSV
    MyExtension = "*.csv"
    
    'Get the first CSV file in the folder
    MyFile = Dir(MyPath & MyExtension)
    
    'Create a new Excel workbook
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
    
    'Loop through all CSV files in the folder
    Do While MyFile <> ""
        
        'Open the CSV file
        Set wb = Workbooks.Open(MyPath & MyFile)
        
        'Loop through all sheets in the CSV file
        For Each ws In wb.Worksheets
            
            'Copy the sheet to the new workbook
            ws.Copy After:=NewBook.Sheets(NewBook.Sheets.Count)
            
            'Get the name of the copied sheet
            SheetName = ws.Name
            
            'Rename the copied sheet to match the original sheet name
            Set NewSheet = NewBook.Sheets(NewBook.Sheets.Count)
            NewSheet.Name = SheetName
            
        Next ws
        
        'Close the CSV file
        wb.Close SaveChanges:=False
        
        'Get the next CSV file in the folder
        MyFile = Dir()
        
    Loop
 NewBook.Sheets("Sheet1").Delete
'Prompt the user to select the folder and filename for the new workbook
    With Application.FileDialog(msoFileDialogSaveAs)
        .Title = "Save the new workbook"
        .InitialFileName = "NewWorkbook.xlsx"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "No file selected. The macro will now exit.", vbCritical, "Error"
            Exit Sub
        End If
        NewBook.SaveAs Filename:=.SelectedItems(1), FileFormat:=xlOpenXMLWorkbook
    End With
    NewBook.SaveAs Filename:="F:\Rum\NewWorkbook.xlsx", FileFormat:=xlOpenXMLWorkbook
    
    'Close the new workbook
NewBook.Close SaveChanges:=True
Application.DisplayAlerts = True
    
End Sub