0

これが私の質問の詳細です。

  • 1 つの Excel ファイルに結合する必要がある何千もの csv ファイルがあります。
  • 各 csv ファイルの特定のデータ、A2、G2、および H セルの最高値のみを抽出する必要がありました。
  • 抽出されたすべてのcsvファイルは、抽出の順序で配置された新しいワークブックになります。(csv A2->A セル、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

最大値の結果は常にゼロを返します。なんで？誰でも私を修正できますか？

4

1 に答える 1

0

あなたの要件を完全に理解したかどうかはわかりませんが、これが役立つかどうかを確認してください.

このコードを新しいワークブックのモジュールに貼り付け、CSV ファイルを "CSV" というサブフォルダーに入れます。結果は、新しいブックのシート 1 に表示されます。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
于 2012-11-19T04:19:30.097 に答える