從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