合并一个Excel工作表中的多个CSV文件
在互联网上search了很多东西之后，我尝试将一个工作的Excel VBA代码合并到一个文件夹中的所有.csv文件中（每个文件都在一个单独的工作表上）。 但我唯一需要的是结合1工作表中的所有CSV文件….
工作代码是：
工作文件分成单独的工作表
Sub Example12() Dim MyPath As String Dim FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long Dim Fnum As Long Dim mybook As Workbook Dim basebook As Workbook 'Fill in the path\folder where the files are 'on your machine MyPath = "c:\Data" 'Add a slash at the end if the user forget it If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If 'If there are no Excel files in the folder exit the sub FilesInPath = Dir(MyPath & "*.csv") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If On Error GoTo CleanUp Application.ScreenUpdating = False Set basebook = ThisWorkbook 'Fill the array(myFiles)with the list of Excel files in the folder Fnum = 0 Do While FilesInPath <> "" Fnum = Fnum + 1 ReDim Preserve MyFiles(1 To Fnum) MyFiles(Fnum) = FilesInPath FilesInPath = Dir() Loop 'Loop through all files in the array(myFiles) If Fnum > 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) mybook.Worksheets(1).Copy after:= _ basebook.Sheets(basebook.Sheets.Count) On Error Resume Next ActiveSheet.Name = mybook.Name On Error GoTo 0 ' You can use this if you want to copy only the values ' With ActiveSheet.UsedRange ' .Value = .Value ' End With mybook.Close savechanges:=False Next Fnum End If CleanUp: Application.ScreenUpdating = True End Sub --------------------------------------------------------- But the change i've made was to change the part where the VBA copies it into a sheet "after" the last one, to append it to a existing sheet "Totaal". not working code --------------------------------------------------------- Sub Example12() Dim MyPath As String Dim FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long Dim Fnum As Long Dim mybook As Workbook Dim basebook As Workbook 'Fill in the path\folder where the files are 'on your machine MyPath = "c:\Data" 'Add a slash at the end if the user forget it If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If 'If there are no Excel files in the folder exit the sub FilesInPath = Dir(MyPath & "*.csv") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If On Error GoTo CleanUp Application.ScreenUpdating = False Set basebook = ThisWorkbook 'Fill the array(myFiles)with the list of Excel files in the folder Fnum = 0 Do While FilesInPath <> "" Fnum = Fnum + 1 ReDim Preserve MyFiles(1 To Fnum) MyFiles(Fnum) = FilesInPath FilesInPath = Dir() Loop 'Loop through all files in the array(myFiles) If Fnum > 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) mybook.Worksheets(1).Copy **basebook.Sheets("Totaal").Select NextRow = Cells(Rows.Count, 0).End(xlUp).Row Cells(NextRow, 1).Select ActiveSheet.Paste** On Error Resume Next ActiveSheet.Name = mybook.Name On Error GoTo 0 ' You can use this if you want to copy only the values ' With ActiveSheet.UsedRange.Value = .Value ' End With mybook.Close savechanges:=False Next Fnum End If CleanUp: Application.ScreenUpdating = True End Sub
我还没有知识来改变这个:(。我在正确的轨道上？
所有的input将不胜感激！
额外信息：CSV文件中的数据放在第一列。 在整个合并过程之后，我计划在之后进行拆分。
谢谢！
Set basebook = ThisWorkbook
input这个：
Dim nextRow As Integer Dim wsTotal As Worksheet Set wsTotal = basebook.Worksheets("Total")
这里是更正的For循环：
'Loop through all files in the array(myFiles) If Fnum > 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) 'open file Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) With wsTotal 'activate if you want (optional) '.Activate 'copy all the data on the sheet mybook.Worksheets(1).UsedRange.Copy 'find the next empty row nextRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1 'select if desired (optional) '.Cells(NextRow, 1).Select 'paste the data .Cells(nextRow, 1).PasteSpecial (xlPasteAll) 'turn off copy mode Application.CutCopyMode = False 'Do you really want to change the worksheet name? .Name = mybook.Name End With 'close file mybook.Close savechanges:=False Next Fnum
要导入CSV文件，我会build议使用查询，而不是打开它们。 这样，您还可以随时执行数据到列的拆分：
Sub ImportToNewWorksheet(ImpFileName as String) Dim mySheet As Worksheet Set mySheet = ThisWorkbook.Worksheets.Add Call ImportFile(ImpFileName, mySheet.Cells(1,1)) End Sub Sub ImportFile(ImpFileName As String, ImpDest As Range) With ImpDest.Worksheet.QueryTables.Add(Connection:= _ "TEXT;" & ImpFileName, Destination:=ImpDest) .Name = "Import" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 65001 .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With End Sub