logo标签列表

在单个工作簿中导入多个CSV文件到多个工作表

vbaexcelcsv
17

我该如何实现这个功能？ 我想要把多个CSV文件导入到一个工作簿的不同工作表中。以下是我想要循环的VBA代码。我需要循环查询C:\test\中的所有CSV文件。

Sub Macro()
With ActiveSheet.QueryTables.Add(Connection:= _
    "TEXT;C:\test\test1.csv", Destination:=Range("$A$1"))
    .Name = "test1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
Sheets.Add After:=Sheets(Sheets.Count)
End Sub
5个回答
20

这位大神写的非常简洁的代码，在我的2010版本中完美运行。所有功劳归于他（Jerry Beaucaire）。我是在一个论坛上发现它的。

Option Explicit
Sub ImportCSVs()
'Author:    Jerry Beaucaire
'Date:      8/16/2010
'Summary:   Import all CSV files from a folder into separate sheets
'           named for the CSV filenames

'Update:    2/8/2013   Macro replaces existing sheets if they already exist in master workbook

Dim fPath   As String
Dim fCSV    As String
Dim wbCSV   As Workbook
Dim wbMST   As Workbook

Set wbMST = ThisWorkbook
fPath = "C:\test\"                  'path to CSV files, include the final \
Application.ScreenUpdating = False  'speed up macro
Application.DisplayAlerts = False   'no error messages, take default answers
fCSV = Dir(fPath & "*.csv")         'start the CSV file listing

    On Error Resume Next
    Do While Len(fCSV) > 0
        Set wbCSV = Workbooks.Open(fPath & fCSV)                    'open a CSV file
        wbMST.Sheets(ActiveSheet.Name).Delete                       'delete sheet if it exists
        ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count)    'move new sheet into Mstr
        Columns.Autofit             'clean up display 
        fCSV = Dir                  'ready next CSV
    Loop

Application.ScreenUpdating = True
Set wbCSV = Nothing
End Sub
1
这似乎在2013年无法正常工作（除非我漏了什么）。我将此脚本复制到启用宏的Excel工作簿（2013）中并运行它（指定目录中有两个.csv文件）。当我运行它时，它打开了两个新的Excel实例（两个新的工作簿），每个工作簿中都有一个工作表，并且原始工作簿中没有任何内容。这个脚本需要更新吗？ - kmote
很抱歉，我可能没有时间进行调查。请随时更新答案。 - Mark Ch
6

注意，这个并不会处理错误，比如如果你导入了一个重复的表格名称的 csv 文件。

这里使用的是早期绑定，所以你需要在 VBE 中的 工具..引用 下引用 Microsoft.Scripting.Runtime。

Dim fs  As New FileSystemObject
Dim fo As Folder
Dim fi As File
Dim wb As Workbook
Dim ws As Worksheet
Dim sname As String

Sub loadall()
    Set wb = ThisWorkbook

    Set fo = fs.GetFolder("C:\TEMP\")

    For Each fi In fo.Files
        If UCase(Right(fi.name, 4)) = ".CSV" Then
            sname = Replace(Replace(fi.name, ":", "_"), "\", "-")

            Set ws = wb.Sheets.Add
            ws.name = sname
            Call yourRecordedLoaderModified(fi.Path, ws)
        End If
    Next
End Sub

Sub yourRecordedLoaderModified(what As String, where As Worksheet)
With ws.QueryTables.Add(Connection:= _
    "TEXT;" & what, Destination:=Range("$A$1"))
    .name = "test1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
Sheets.Add After:=Sheets(Sheets.Count)
End Sub
3

您可以使用Dir来过滤并仅运行csv文件。

Sub MacroLoop()
Dim strFile As String
Dim ws As Worksheet
strFile = Dir("c:\test\*.csv")
Do While strFile <> vbNullString
Set ws = Sheets.Add
With ws.QueryTables.Add(Connection:= _
    "TEXT;" & "C:\test\" & strFile, Destination:=Range("$A$1"))
    .Name = strFile
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End Sub
工作表名称不反映此代码所使用的CSV文件的文件名。我该如何解决这个问题？ - Dumont
我已经解决了工作表的文件名。我的新问题是，我遇到了内存不足的错误。我正在导入大约80个CSV文件。 - Dumont
@Dumont，从文件名上看，我想您应该能看到我使用了一个变量。关于您的内存错误，它正在导入多少个CSV文件？您接受的其他代码是否有效，因为它使用相同的导入方法（但首先测试每个文件类型）？ - brettdj
是的，它会给出相同的错误。我正在导入大约80个CSV文件。 - Dumont
只有80个CSV文件中的30个被导入到Excel中。 - Dumont
2
现在没问题了。看起来当CSV没有内容时，代码会失败。我只是添加了 On Error Resume Next。 - Dumont
2
我有183个csv文件需要压缩成一个工作簿，每个csv文件对应一个工作表，以便于分析数据，我不想手动一个一个地完成。我尝试了这个问题上最受欢迎的解决方案，但和其他用户一样遇到了同样的问题：csv文件可以打开，但是没有插入到目标工作簿中。我花了一些时间调整代码，使其在Excel 2016中运行。我没有在旧版本上进行测试。我已经很久没有编写Visual Basic代码了，所以我的代码可能还有很大的改进空间，但它在我急需时起到了作用。如果有人偶然发现了这个问题，就像我一样，我会在下面粘贴我使用的代码。
Option Explicit
Sub ImportCSVs()
'Author:    Jerry Beaucaire
'Date:      8/16/2010
'Summary:   Import all CSV files from a folder into separate sheets
'           named for the CSV filenames

'Update:    2/8/2013   Macro replaces existing sheets if they already exist in master workbook
'Update: base script as seen in: https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/merge-functions/csvs-to-sheets
'Update: adjusted code to work in Excel 2016

Dim fPath   As String
Dim fCSV    As String
Dim wbName  As String
Dim wbCSV   As Workbook
Dim wbMST   As Workbook


wbName = "this is a string"
Set wbMST = ThisWorkbook

fPath = "C:\pathOfCSVFiles\"                  'path to CSV files, include the final \
Application.ScreenUpdating = False  'speed up macro
Application.DisplayAlerts = False   'no error messages, take default answers
fCSV = Dir(fPath & "*.csv")         'start the CSV file listing

    On Error Resume Next
    Do While Len(fCSV) > 0
        Set wbCSV = Workbooks.Open(fPath & fCSV)                    'open a CSV file
        If wbName = "this is a string" Then 'this is to check if we are just starting out and target workbook only has default Sheet 1
            wbCSV.Sheets.Copy After:=wbMST.Sheets(1) 'for first pass, can leave as is. if loading a large number of csv files and excel crashes midway, update this to the last csv that was loaded to the target workbook
        Else
            wbCSV.Sheets.Copy After:=wbMST.Sheets(wbName) 'if not first pass, then insert csv after last one
        End If

        fCSV = Dir                  'ready next CSV
        wbName = ActiveSheet.Name 'save name of csv loaded in this pass, to be used in the next pass
    Loop

Application.ScreenUpdating = True
Set wbCSV = Nothing
End Sub
0

我没有尝试过这个，但我会选择this：

Dim NumFound As Long 
With Application.FileSearch 
    .NewSearch
    .LookIn = "C:\test\"
    .FileName = "*.csv"
    If .Execute() > 0 Then 
        For i = 1 To .FoundFiles.Count
            With ActiveSheet.QueryTables.Add(Connection:= _
                "TEXT;" & "C:\test\" & (Application.FileSearch.FoundFiles(i)), Destination:=Range("$A$1"))
                ...
            End With
            Sheets.Add After:=Sheets(Sheets.Count)
        Next i
    End If
End With
1
Application.FileSearch在Office 2007中已被弃用，因此这不太适合使用。 - brettdj
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接