将CSV文件复制到一个xlsm工作簿
我试图从一个文件夹中的500个CSV文件中提取数据（xlsm文件在同一个文件夹中）。 我有vba检查，看是否有足够的可用行在工作表，以适应下一个文件复制/粘贴，如果没有那么它将创build一个新的工作表，并从范围（a1）开始新的工作表。 在最后的msgbox只是一个双重检查，以确保所有的文件都复制。
问题是，一些数据不复制，我不明白为什么。 思考？
Public CurrRow, RemRows, TotRows As Long Sub Open_CSV() Dim MyFile, FolderPath, myExtension As String 'Dim MyObj As Object, MySource As Object, file As Variant Dim csv As Variant Dim wb As Workbook Dim strDir As String Dim fso As Object Dim objFiles As Object Dim obj As Object Dim lngFileCount, lastrow As Long FolderPath = Application.ActiveWorkbook.Path & Application.PathSeparator 'assigning path to get to both workbooks folder myExtension = "*.csv" 'only look at csv files MyFile = Dir(CurDir() & "\" & myExtension) 'setting loop variable to ref folder and files 'getting a count of total number of files in folder strDir = Application.ActiveWorkbook.Path Set fso = CreateObject("Scripting.FileSystemObject") Set objFiles = fso.GetFolder(strDir).Files lngFileCount = objFiles.Count y = lngFileCount - 2 'folder file count minus tool.CSV_Import2 file x = 1 'setting loop counter Z = 1 'setting counter for new sheets TotRows = 1048576 'total number of rows per sheet Application.ScreenUpdating = False Application.DisplayAlerts = False Do While MyFile <> "" Set wb = Workbooks.Open(Filename:=FolderPath & MyFile) wb.Activate With ActiveSheet lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row End With If x = 1 Then 'need to make the first paste of data in the first row Range("A1").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Windows("tool.CSV_Import2.xlsm").Activate Range("A1").Select ActiveSheet.Paste Else Range("A1").Select 'making all pastes after the first file to the next empty row Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Windows("tool.CSV_Import2.xlsm").Activate Range("A1").Select Selection.End(xlDown).Select Selection.Offset(1, 0).Select CurrRow = ActiveCell.Row 'last row with data number RemRows = TotRows - CurrRow 'how many rows are left? If lastrow < RemRows Then 'if the import has fewer row than available rows ActiveSheet.Paste Else Sheets.Add.Name = Z Sheets(Z).Activate Z = Z + 1 Range("A1").Select 'direct paste here is applicable since it's the first paste ActiveSheet.Paste End If End If wb.Close 'close file If x = y Then 'if loop counter is equal to number of csv files in folder exit loop Exit Do End If x = x + 1 Loop MsgBox x End Sub 你的数据是否有“空白”？
如果是这样，你的行Range(Selection, Selection.End(xlDown)).Select将尽可能多的select空白，即使可能有以下的数据。
尝试改变它们到Range(Selection, Selection.End(xlUp)).Select
回应你的评论：
是的，也是这样。 做好识别问题。 你似乎并没有改变MyFile在你的“Do While MyFile <>”“”循环中的任何地方。
build议你考虑把这个循环变成一个'For objFiles'中的每一个wb'循环，并相应地调整你的代码。 使用这种方法，您不必计数，跟踪或testing文件的进度。
我需要补充
MyFile = Dir
之前的“循环”在代码结束。
这使我能够遍历每个文件。