从CSV文件中提取数据到一个excel文件

Question

这里是我的问题的细节。

• 我有成千上万的csv文件需要合并在一个excel文件中。
• 只需要提取每个csv文件的某些数据，A2，G2和H cell的最高值。
• 提取的每个csv文件都将位于按工作表顺序排列的新工作簿中。 （CSV A2->的细胞，CSV G2-> B细胞，CSV H->细胞）

因为我有成千上万的CSV文件，是能够结合所有的数据，通过选择在所有的CSV文件另一个文件夹？

非常感谢您的关注。

Option Explicit 

Function ImportData() 

Dim wkbCrntWorkBook As Workbook 
Dim wkbSourceBook As Workbook 
Dim rngSourceRange1 As Range 
Dim rngSourceRange2 As Range 
Dim rngSourceRange3 As Range 
Dim rngDestination1 As Range 
Dim rngDestination2 As Range 
Dim rngDestination3 As Range 
Dim intColumnCount As Integer 

Dim YesOrNoAnswerToMessageBox As String 
Dim QuestionToMessageBox As String 

Set wkbCrntWorkBook = ActiveWorkbook 

Dim SelectedItemNumber As Integer 

Dim HighestValueRng As Range 
Dim Highest As Double 

Do 

SelectedItemNumber = SelectedItemNumber + 1 

With Application.FileDialog(msoFileDialogOpen) 
    .Filters.Clear 
    .Filters.Add "Excel 2007", "*.xlsx; *.xlsm; *.xlsa", 1 
    .Filters.Add "Excel 2002-03", "*.xls", 2 
    .Filters.Add "Command Separated Values", "*.csv", 3 
    .AllowMultiSelect = True 
    .Show 

For SelectedItemNumber = 1 To .SelectedItems.Count 

    If .SelectedItems.Count > 0 Then 
     Workbooks.Open .SelectedItems(SelectedItemNumber) 
     Set wkbSourceBook = ActiveWorkbook 
     Set rngSourceRange1 = ActiveCell.Offset(1, 0) 
     Set rngSourceRange2 = ActiveCell.Offset(1, 6) 


     wkbCrntWorkBook.Activate 

     Set rngDestination1 = ActiveCell.Offset(1, 0) 
     Set rngDestination2 = ActiveCell.Offset(1, 1) 

     ActiveCell.Offset(1, 2).Value = Application.WorksheetFunction.Max(Columns("H")) 

     For intColumnCount = 1 To rngSourceRange1.Columns.Count 

      If intColumnCount = 1 Then 
       rngSourceRange1.Columns(intColumnCount).Copy rngDestination1 
      Else 
       rngSourceRange1.Columns(intColumnCount).Copy rngDestination1.End(xlDown).End(xlDown).End(xlUp).Offset(1) 
      End If 
     Next 

     For intColumnCount = 1 To rngSourceRange2.Columns.Count 

      If intColumnCount = 1 Then 
       rngSourceRange2.Columns(intColumnCount).Copy rngDestination2 
      Else 
       rngSourceRange2.Columns(intColumnCount).Copy rngDestination2.End(xlDown).End(xlDown).End(xlUp).Offset(1) 
      End If 
     Next 

     ActiveCell.Offset(1, 0).Select 

     wkbSourceBook.Close False 
    End If 

Next SelectedItemNumber 

End With 

YesOrNoAnswerToMessageBox = MsgBox("Continue?", vbYesNo) 

Loop While YesOrNoAnswerToMessageBox = vbYes 


Set wkbCrntWorkBook = Nothing 
Set wkbSourceBook = Nothing 
Set rngSourceRange1 = Nothing 
Set rngSourceRange2 = Nothing 
Set rngDestination1 = Nothing 
Set rngDestination2 = Nothing 
intColumnCount = Empty 

End Function 

最大值的结果总是返回零。为什么？任何人都可以纠正我？

Answer 1

如果我完全了解您的要求，则不是积极的，但请看看这是否对您有所帮助。

将此代码粘贴到新工作簿中的模块中，并将您的CSV文件放入名为“CSV”的子文件夹中。结果应显示在新工作簿的Sheet1中。请注意，它只会检查CSV文件扩展名的文件。如果你需要改变这一点，看看这一行If Right(file.Name, 3) = "csv"

Sub ParseCSVs() 
    Dim CSVPath 
    Dim FS 
    Dim file 
    Dim wkb As Excel.Workbook 
    Dim ResultsSheet As Worksheet 
    Dim RowPtr As Range 
    Dim CSVUsed As Range 

    Set ResultsSheet = Sheet1 

    'Clear the results sheet 
    ResultsSheet.Cells.Delete 

    Set FS = CreateObject("Scripting.FileSystemObject") 

    'The CSV files are stored in a "CSV" subfolder of the folder where 
    'this workbook is stored. 
    CSVPath = ThisWorkbook.Path & "\CSV" 

    If Not FS.FolderExists(CSVPath) Then 
     MsgBox "CSV folder does not exist." 
     Exit Sub 
    End If 

    ResultsSheet.Range("A1:D1").Value = Array("CSV A2", "CSV G2", "CSV Max of H", "File") 
    ResultsSheet.Range("A1").EntireRow.Font.Bold = True 
    Set RowPtr = ResultsSheet.Range("A2") 
    For Each file In FS.GetFolder(CSVPath).Files 
     If Right(file.Name, 3) = "csv" Then 'Only look at files with .csv extension 
      Set wkb = Application.Workbooks.Open(file.Path) 
      Set CSVUsed = wkb.Sheets(1).UsedRange 

      RowPtr.Range("A1") = CSVUsed.Range("A2") 
      RowPtr.Range("B1") = CSVUsed.Range("G2") 
      RowPtr.Range("C1") = Application.WorksheetFunction.Max(CSVUsed.Range("H:H")) 
      RowPtr.Range("D1") = file.Name 

      wkb.Close False 

      Set RowPtr = RowPtr.Offset(1) 
     End If 
    Next 

    ResultsSheet.Range("A:D").EntireColumn.AutoFit 
End Sub