将CSV文件复制到一个xlsm工作簿

Question

我试图从一个文件夹中的500个CSV文件中提取数据（xlsm文件位于同一文件夹中）。我有vba检查来查看表单中是否有足够的可用行来适应要复制/粘贴的下一个文件，如果没有，则会创建一个新表并从范围（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 

Answer 1

我需要添加

MyFile = Dir 

“循环”之前，在代码的末尾。

这使我能够遍历每个文件。

Answer 2

您的数据是否存在“空白”？

如果是这样，您的行Range(Selection, Selection.End(xlDown)).Select将选择差距，即使可能有以下数据。

尝试改变这些以Range(Selection, Selection.End(xlUp)).Select

针对您的评论：

是看起来太。做好识别问题。你似乎没有改变MyFile在你的'Do While MyFile <>''''循环中的任何地方。

建议您考虑对此循环进行分箱以支持'For Each wb in objFiles'循环并相应地调整您的代码。使用这种方法，您不必计数，跟踪或测试文件进度。