Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2471 / 13645 ツリー ←次へ | 前へ→

【67353】特定の範囲内の値をもつ行を抽出しコピーする方法(CSVファイル) 高校新人教師 10/11/27(土) 5:12 質問[未読]
【67354】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/11/27(土) 8:52 発言[未読]
【67355】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/11/27(土) 9:25 発言[未読]
【67356】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/11/27(土) 10:31 回答[未読]
【67365】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 10/11/28(日) 6:51 お礼[未読]
【67367】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/11/28(日) 11:26 回答[未読]
【67368】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/11/28(日) 11:29 回答[未読]
【67414】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 10/12/1(水) 23:52 お礼[未読]
【67415】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/12/2(木) 8:57 回答[未読]
【67533】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 10/12/11(土) 2:24 お礼[未読]
【67536】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/12/11(土) 9:51 回答[未読]
【67612】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 10/12/18(土) 7:17 質問[未読]
【67615】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 10/12/18(土) 9:59 回答[未読]
【67731】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 11/1/5(水) 19:36 お礼[未読]
【67846】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 11/1/13(木) 4:58 質問[未読]
【67847】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 11/1/13(木) 9:40 回答[未読]
【67730】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 11/1/5(水) 19:34 回答[未読]
【67764】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 11/1/7(金) 3:35 お礼[未読]
【67766】Re:特定の範囲内の値をもつ行を抽出しコピ... Hirofumi 11/1/7(金) 8:00 回答[未読]
【67845】Re:特定の範囲内の値をもつ行を抽出しコピ... 高校新人教師 11/1/13(木) 4:45 お礼[未読]

【67353】特定の範囲内の値をもつ行を抽出しコピー...
質問  高校新人教師  - 10/11/27(土) 5:12 -

引用なし
パスワード
   はじめまして、VBA初心者のものです。
皆様にお聞きしたい事を調べていて過去ログを調べておりましたところ、
参考になるコードをいくつか発見する事ができたのですが、それらの組み合わせてあつかうことが初心者ゆえかできず、
大変恐縮ですが、質問させていただきました。早急に分析せねばならず、ご教授お願いします。

以下のような高校生の模擬テスト平均点などを記した、[,]カンマ区切りのCSVファイルがフォルダ内に複数あります。

氏名,クラス,住所,受験日時,自由コメント,数学の平均点,英語の平均点  (実際のファイルにはこちらの行は記載されておりません。下の行が1行目です。)
鈴木さん,A,東京都◯◯◯◯,12:00:00,コメント◯◯◯◯,70.40,55.33
佐藤さん,B,神奈川県◯◯◯◯,3:00:00,コメント◯◯◯◯,60.43,80.31
伊藤さん,C,神奈川県◯◯◯,3:00:00,コメント◯◯◯◯,80.77,68.29
  ・
  ・
  ・
  ・
  ・
  ・
  ・
  ・

このように何百行か続きます。

これらのいくつかのファイルについて、例えば、数学の平均点が70.34~80.66の間でかつ英語の平均点が50.54~60.11の間の点数をとった生徒の行をすべて抽出し、
別のcsvファイルにコピーして、特定のフォルダの中に保存していく。
その後、これらの書き出されたcsvファイルを一つに連結したものを別のcsvファイルとして保存する。

ということをしたく思っております。

ただし、
行によっては、自由コメントの中に[,]が記述されいる場合があり、Excel上では、セルの列が何列かずれている事がある。
数学、英語の平均点がそもそも記載されていない行がある。
という問題があります。

【67354】Re:特定の範囲内の値をもつ行を抽出しコ...
発言  Hirofumi  - 10/11/27(土) 8:52 -

引用なし
パスワード
   >ただし、
>行によっては、自由コメントの中に[,]が記述されいる場合があり、
>Excel上では、セルの列が何列かずれている事がある。

此れ、自由コメントのフィールドは「"」で括られていませんか?

>これらのいくつかのファイルについて、例えば、数学の平均点が70.34~80.66の間で
>かつ英語の平均点が50.54~60.11の間の点数をとった生徒の行をすべて抽出し、
>別のcsvファイルにコピーして、特定のフォルダの中に保存していく。
>その後、これらの書き出されたcsvファイルを一つに連結したものを別のcsvファイルとして保存する。

此れも、最初から1つのCSVにしてはいけないのですか?

【67355】Re:特定の範囲内の値をもつ行を抽出しコ...
発言  Hirofumi  - 10/11/27(土) 9:25 -

引用なし
パスワード
   後、Excelのヴァージョンを教えて下さい

【67356】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/11/27(土) 10:31 -

引用なし
パスワード
   こんな物では?
File選択のダイアログがExcel2002以降用ですので、
それ以外の場合は別なプロシージャと入れ替えます

Sheet1のB2に数学の抽出平均点下限、C2に数学の抽出平均点上限
同じく、B3に英語の抽出平均点下限、C3に英語の抽出平均点上限を記入して実行します

Option Explicit

Public Sub DataExtract()

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntMark As Variant
  Dim strProm As String

  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '抽出する下限、上限値を取得
  vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value
  
  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo
  
  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), dfo, vntMark
  Next i

  Close dfo
  
  strProm = "処理が完了しました"

Wayout:

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          dfo As Integer, _
          vntMark As Variant, _
          Optional strDelim As String = ",")

  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim lngMax As Long
  
  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti)
    'フィールド内で改行が有る場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        lngMax = UBound(vntField)
        '数学の上下限で且つ英語の上下限に入るなら
        If vntMark(1, 1) <= Val(vntField(lngMax - 1)) _
            And Val(vntField(lngMax - 1)) <= vntMark(1, 2) Then
          If vntMark(2, 1) <= Val(vntField(lngMax)) _
                    And Val(vntField(lngMax)) <= vntMark(2, 2) Then
            Print #dfo, strRec
          End If
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

  Dim i As Long
  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim vntField As Variant
  Dim lngLength As Long

  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart)
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart

  SplitCsv = vntData()

End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean = False, _
            Optional strTitle As String) As Boolean

'  FileDialog使用版

  Dim i As Long
  Dim objFDL As FileDialog
  Dim vntSelected As Variant
  Dim vntFilters As Variant
  
  'Filterを指定
  vntFilters = Array("CSV File", "*.csv", "Text File", "*.txt", _
            "CSV and Text", "*.csv;*.txt", "全て", "*.*")
  
  '[ファイル参照] ダイアログの FileDialog オブジェクトを作成
  Set objFDL = Application.FileDialog(msoFileDialogFilePicker)

  'Show メソッドでダイアログを表示し、ユーザーのアクションを取得
  With objFDL
    'タイトルを設定
    If strTitle <> "" Then
      .Title = strTitle
    End If
    '初期フォルダ及び、指定ファイル名を設定
    If strFilePath <> "" Then
      .InitialFileName = strFilePath
    End If
    'Filterを設置
    With .Filters
      .Clear
      For i = 0 To UBound(vntFilters) Step 2
        .Add vntFilters(i), vntFilters(i + 1), i \ 2 + 1
      Next i
    End With
    '表示するFilterを設定
    .FilterIndex = 1
    'MultiSelectを設定
    .AllowMultiSelect = blnMultiSel
    'ユーザーがボタンをクリック
    If .Show = -1 Then
      If blnMultiSel Then
        'ファイル名保存する配列を確保
        ReDim vntFileNames(1 To .SelectedItems.Count)
        'FileDialogSelectedItemsコレクション内のすべてのファイル名を取得
        i = 0
        For Each vntSelected In .SelectedItems
          '選択した各アイテムのパスを含む値を取得
          i = i + 1
          vntFileNames(i) = vntSelected
        Next vntSelected
      Else
        vntFileNames = .SelectedItems(1)
      End If
      '戻り値としてTrueを返す
      GetReadFile = True
    End If
  End With

  Set objFDL = Nothing
  
End Function

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String, _
            Optional strTitle As String) As Boolean

'  FileDialog使用版

  Dim i As Long
  Dim objFDL As FileDialog
  Dim vntSelected As Variant
  
  '[ファイル参照] ダイアログの FileDialog オブジェクトを作成
  Set objFDL = Application.FileDialog(msoFileDialogSaveAs)

  'Show メソッドでダイアログを表示し、ユーザーのアクションを取得
  With objFDL
    'タイトルを設定
    If strTitle <> "" Then
      .Title = strTitle
    End If
    '初期フォルダ及び、指定ファイル名を設定
    If strFilePath <> "" Then
      .InitialFileName = strFilePath
    End If
    '表示するFilterを設定
    .FilterIndex = 15 '★変更が必要かも?
    'MultiSelectを設定
    .AllowMultiSelect = False
    'ユーザーがボタンをクリック
    If .Show = -1 Then
      vntFileName = .SelectedItems(1)
      '戻り値としてTrueを返す
      GetWriteFile = True
    End If
  End With

  Set objFDL = Nothing

End Function

【67365】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 10/11/28(日) 6:51 -

引用なし
パスワード
   ▼Hirofumi さん:

大変ありがとうございました。
こんなに短期間でご教授いただきまして大変感謝しています。
Excelは2007を使用しております。

先ほど、やってみたところ問題なく抽出できたようです。

非常に丁寧に教えてくださっているので、これから勉強していく際に非常に参考になります。

続けて質問してしまって大変恐縮ですが、
平均点の下限、上限を指定するだけでなく、
投稿時間が12:00:00~15:00:00をの行を抽出したり、
名前やコメントの中で、例えば「鈴木」という名前がある行を同様に抽出するためには、
どのようにコードを変えていけばよいのでしょうか?

【67367】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/11/28(日) 11:26 -

引用なし
パスワード
   >続けて質問してしまって大変恐縮ですが、
>平均点の下限、上限を指定するだけでなく、
>投稿時間が12:00:00~15:00:00をの行を抽出したり、
>名前やコメントの中で、例えば「鈴木」という名前がある行を同様に抽出するためには、
>どのようにコードを変えていけばよいのでしょうか?

このコードは、私が使っている古臭いコードを少し編集した物なので処理速度を求める等なら
もっと改良が必要だと思います

先ず、
1、「Function GetReadFile」と「Function GetWriteFile」は
 「ファイルを開く」、「保存するファイル名」を出すプロシージャで
 特に今回の場合変更はしなくても善いかと思います

2、「Function SplitCsv」はCSV用の分割関数で
 戻り値は、Vriant型の配列で、添え字の基底が0の1次元配列と成ります
 Delimiterが無い場合は、基底だけの配列にstrLineで与えた文字列が帰ります
 また、フィールドが「"」で括られている場合其の処理を行います
 (「"」で括られているフィールドの中に在る「,」はデータと見なし分割されません)
 引数 strLine は分割元の文字列を与えます
 引数 strDelimiter、引数 strQuote、引数 strRetは通常は指定しません
 引数 blnMultiは分割する文字列の中に在る、「"」を「,」を比較し辻褄が合わない場合
    Trueを返します(例えば「"」で括られているフィールドの中に改行コーど等が在る場合)

抽出条件を代えたプログラムを幾つか作るのでしょうから、
上記3点のプロシージャを別な標準モジュールを設けて其処に移動します
そして、3点ともPrivate宣言されていますので、其れをPublicの宣言に変更します
そうすれば、どのモジュールからも呼び出せますので、一々上記のプロシージャを
増殖させる必要は在りません

変更の殆どは「Sub DataExtract」、「SuB CSVRead」で行う事に成りますので
要点だけを書きます
上記と別な標準モジュールに「Sub DataExtract」と「 Sub CSVRead」をCopyして
「Sub DataExtract」の名前を変更します

a) 例、受験時間が12:00:00~15:00:00をの行を抽出

Sheet1のB5に下限、C5に上限時間を書くとします
「Sub DataExtract」の変更部分

  '抽出する下限、上限値を取得
  vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value



  '抽出する下限、上限値を取得
  vntMark = Worksheets("Sheet1").Cells(5, "B").Resize(, 2).Value

とします

「 Sub CSVRead」の変更

  Dim strRec As String
'  Dim lngMax As Long ' ★削除
 ・
 ・

    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        '但し、コメントフィールドの「,」が在る場合、「"」で括られているなら
        '受験時間が12:00:00~15:00:00をの行を抽出
        If vntMark(1, 1) <= TimeValue(vntField(3)) _
            And TimeValue(vntField(3)) <= vntMark(1, 2) Then
            '合成レコードを出力
            Print #dfo, strRec
          End If
        End If
      End If
      strRec = ""
    Else

とします

b) 例、名前やコメントの中で、例えば「鈴木」という名前がある行を抽出

Sheet1のE2から下にE3、E4・・と名前を書くとします
「Sub DataExtract」の変更部分

  '抽出する下限、上限値を取得
  vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value



  '抽出する名前を取得
  With Worksheets("Sheet1")
    vntMark = .Range(.Cells(2, "E"), .Cells(Rows.Count, "E").End(xlUp).Offset(1)).Value
  End With

とします

「 Sub CSVRead」の変更

  Dim strRec As String
'  Dim lngMax As Long ' ★削除
  Dim i As Long ' ★追加

 ・
 ・
  
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        '但し、コメントフィールドの「,」が在る場合、「"」で括られているなら
        '名前やコメントの中で、例えば「鈴木」という名前がある行を抽出
        For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, vntField(0), vntMark(i, 1), vbBinaryCompare) > 0 _
              Or InStr(1, vntField(4), vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i
        'もし指定文字列が有った場合
        If i <= UBound(vntMark, 1) - 1 Then
          '合成レコードを出力
          Print #dfo, strRec
        End If
      End If
      strRec = ""
    Else

とします

以上

【67368】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/11/28(日) 11:29 -

引用なし
パスワード
   ごめん、a)で、End Ifが一つ余計でした

    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        '但し、コメントフィールドの「,」が在る場合、「"」で括られているなら
        '受験時間が12:00:00~15:00:00をの行を抽出
        If vntMark(1, 1) <= TimeValue(vntField(3)) _
            And TimeValue(vntField(3)) <= vntMark(1, 2) Then
          '合成レコードを出力
          Print #dfo, strRec
        End If
      End If
      strRec = ""

と成ります

【67414】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 10/12/1(水) 23:52 -

引用なし
パスワード
   ▼Hirofumi さん:
返信が遅れて申し訳ありません。
先ほど、VBAを書き換えてみたところ、抽出できました。
ありがとうございました。

教えていただいたコードで、
該当する文字がないだけのかもしれないのですが、数学および英語の平均点
に関係なく、ただ指定したいくつか文字列が書かれている行を抽出することはできるのでしょうか?
これは数学と英語の平均点の上限、下限を指定するセルを未入力
にしておくだけは、結果が抽出されないようなのですが。

あと探したい文字列の指定なのですが、
E2かつE3となっていくのでしょうか、それとも、それともE2またはE3となるのでしょうか?
どちらにも変更できればうれしいのですが。

【67415】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/12/2(木) 8:57 -

引用なし
パスワード
   >教えていただいたコードで、
>該当する文字がないだけのかもしれないのですが、数学および英語の平均点
>に関係なく、ただ指定したいくつか文字列が書かれている行を抽出することはできるのでしょうか?
>これは数学と英語の平均点の上限、下限を指定するセルを未入力
>にしておくだけは、結果が抽出されないようなのですが。

>あと探したい文字列の指定なのですが、
>E2かつE3となっていくのでしょうか、それとも、それともE2またはE3となるのでしょうか?
>どちらにも変更できればうれしいのですが。

此れは、「b) 例、名前やコメントの中で、例えば「鈴木」という名前がある行を抽出」
の事を言っているのでしょう?

この、コード修正では、数学と英語の平均点は全く見て居ません
「氏名」vntField(0)若しくは、「自由コメント」vntField(4)に指定の文字列が在る場合に
抽出する様にして在ります

ただ、前に此方から質問した、「自由コメント」の「,」の問題なのですが?
「自由コメント」のフィールドは「"」で括られた中に「,」が在るのでしょうか?

もし、上記の様に成っていれば、コード上、区切り文字の「,」とデータの「,」と見分けているので
フィールド数の増減は無いのですが?、上記の様に成っていない場合、
「自由コメント」のフィールドが2つ成ったり3つに成ったりするのを考慮する必要が有ります

また、或る文字列が、全フィールドの中に在るのかどうかで善いのなら、以下の様に
フールドに分割されたもので探すのでは無く、分割前のレーコードから探す事も出来ます

    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        'レコード中に、例えば「鈴木」という名前がある行を抽出
        For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i
        'もし指定文字列が有った場合
        If i <= UBound(vntMark, 1) - 1 Then
          '合成レコードを出力
          Print #dfo, strRec
        End If
      End If
      strRec = ""
    Else

【67533】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 10/12/11(土) 2:24 -

引用なし
パスワード
   ▼Hirofumi さん:
>ただ、前に此方から質問した、「自由コメント」の「,」の問題なのですが?
>「自由コメント」のフィールドは「"」で括られた中に「,」が在るのでしょうか?
>
>もし、上記の様に成っていれば、コード上、区切り文字の「,」とデータの「,」と見分けているので
>フィールド数の増減は無いのですが?、上記の様に成っていない場合、
>「自由コメント」のフィールドが2つ成ったり3つに成ったりするのを考慮する必要が有ります
>
>また、或る文字列が、全フィールドの中に在るのかどうかで善いのなら、以下の様に
>フールドに分割されたもので探すのでは無く、分割前のレーコードから探す事も出来ます

返信おくれまして誠に申し訳ありません。海外に出かけていたため、ご連絡できずにいました。
自由コメントは、"コメント"という形式をとっていません。したがって、コメントの中に、「,」あればあるほどその行のフィールド数は増えていきます。

返信をいただいてコードを修正して、何度か試したのですが、探したい文字列が抽出されないようなのですが、

・数学と英語の平均点を無記入にしている。

・対象とするCSVファイルが一つである。

といったことは影響しているのでしょうか?


また、最初に質問させていただいた時の表記がすこし間違っていました。

>以下のような高校生の模擬テスト平均点などを記した、[,]カンマ区切りのCSVファイルがフォルダ内に複数あります。

>氏名,クラス,住所,受験日時,自由コメント,数学の平均点,英語の平均点  (実際のファイルにはこちらの行は記載されておりません。下の行が1行目です。)
鈴木さん,A,東京都◯◯◯◯,12:00:00,コメント◯◯◯◯,70.40,55.33
佐藤さん,B,神奈川県◯◯◯◯,3:00:00,コメント◯◯◯◯,60.43,80.31
伊藤さん,C,神奈川県◯◯◯,3:00:00,コメント◯◯◯◯,80.77,68.29
  ・
  ・
  ・
  ・
  ・
  ・
  ・
  ・


ではなく、
クラス,氏名,受験日時,自由コメント,数学の平均点,英語の平均点  (実際のファイルにはこちらの行は記載されておりません。下の行が1行目です。)
鈴木さん,A,12:00:00,コメント◯◯◯◯,70.40,55.33
佐藤さん,B,3:00:00,コメント◯◯◯◯,60.43,80.31
伊藤さん,C,3:00:00,コメント◯◯◯◯,80.77,68.29
  ・
  ・
  ・
  ・
  ・
  ・
  ・
  ・

申し訳ありません。
もうしかしたら、最初にお答えいただいた、数学と英語の平均点のみを抽出するコードにも影響しているかもしれません。

【67536】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/12/11(土) 9:51 -

引用なし
パスワード
   >返信をいただいてコードを修正して、何度か試したのですが、
>探したい文字列が抽出されないようなのですが、
>
>・数学と英語の平均点を無記入にしている。
>
>・対象とするCSVファイルが一つである。
>
>といったことは影響しているのでしょうか?

「数学と英語の平均点を無記入にしている。」とは、SHeet1のB2:C4の範囲の事ですか?
多分、私が思っている様にコードが変更されているなら「対象とするCSVファイルが一つである」を
含めて関係無いと思います

先ず、質問を整理します

最初の質問の
>これらのいくつかのファイルについて、例えば、数学の平均点が70.34~80.66の間で
>かつ英語の平均点が50.54~60.11の間の点数をとった生徒の行をすべて抽出し、
>別のcsvファイルにコピーして、特定のフォルダの中に保存していく。

と次の質問の

>平均点の下限、上限を指定するだけでなく、
>投稿時間が12:00:00~15:00:00をの行を抽出したり、
>名前やコメントの中で、例えば「鈴木」という名前がある行を同様に抽出するためには、
>どのようにコードを変えていけばよいのでしょうか?

を、其々別な3つのプログラムを作ると解釈しています?ので
その変更方法を指示した積りです

次に、「フィールドの中にカンマが在り、フィールド数が増えてしまうデータが在る」と
言う事に就いて

何回か、お尋ねしているのですが回答が無いので?もう一度確認します
フィールド数が増えるレコードで、「,」が在るコメントのフィールドが「"」で括られていますか?
CSVの仕様に従っている、データなら括られている筈です
まともなアプリケーションで出力された物なら従っていると思います

次に、自分が扱うデータの状況を把握しましょう
1、テキストエディタ(無ければメモ帳でも)でファイルを開いて眺めて見る
 (上記の様に「"」括られているフィールドが在るのか等)
2、Excelのメニューで「開く」を選び直接CSVファイルを開いて見る
 直接開いた時には、「,」と「"」がきちんとされる為、
 CSVの仕様従ったファイルなら列が揃うはずです

次に、高校新人教師さんが修正したコードの「Sub DataExtract」、「Sub CSVRead」に相当する
プロシージャを3プログラム分、Upして下さい
(「Function SplitCsv」、「Function GetReadFile」、「Function GetWriteFile」は同じ筈なのでUpは必要ありません)

【67612】Re:特定の範囲内の値をもつ行を抽出しコ...
質問  高校新人教師  - 10/12/18(土) 7:17 -

引用なし
パスワード
   ▼Hirofumi さん:
お返事おそくなりました。全くの初心者なもので大変ご迷惑をおかけしております。何卒よろしくお願いします。

>「数学と英語の平均点を無記入にしている。」とは、SHeet1のB2:C4の範囲の事ですか?

ご指摘いただいた通りです。

>何回か、お尋ねしているのですが回答が無いので?もう一度確認します
>フィールド数が増えるレコードで、「,」が在るコメントのフィールドが「"」で括られていますか?
>CSVの仕様に従っている、データなら括られている筈です
>まともなアプリケーションで出力された物なら従っていると思います

秀丸にて確認したのですが、コメントのフィールドは「"」で括られておりません。


>次に、高校新人教師さんが修正したコードの「Sub DataExtract」、「Sub CSVRead」に相当する
>プロシージャを3プログラム分、Upして下さい
>(「Function SplitCsv」、「Function GetReadFile」、「Function GetWriteFile」は同じ筈なのでUpは必要ありません)

最初に、コメントの箇所(orすべてのフィールドにおいて)で、探したい文字列がある行を抽出するプログラムですが、以下の通りです。
3つ分ですが、時間のフィールドに時間以外の余計な値が入っているため、申し訳ありませんが、最初にコメント内での文字列のみの抽出に関する質問を優先させていただきます。

質問整理

ある1つないしは複数のcsvファイルにおいて、

クラス,氏名,受験日時,自由コメント,数学の平均点,英語の平均点  (実際のファイルにはこちらの行は記載されておりません。下の行が1行目です。)
A,鈴木さん,12:00:00,コメント◯◯◯◯,70.40,55.33
B,佐藤さん,3:00:00,コメント◯◯◯◯,60.43,80.31
C,伊藤さん,3:00:00,コメント◯◯◯◯,80.77,68.29
  ・
  ・
  ・
  ・
  ・
  ・
  ・
  ・
があり、コメント欄において特定の文字列「○○」が書かれた行をすべて、他のファイルに抽出する。(コメント欄のみだけでなく、すべてのフィールドでも構いません。)
(また、コメントのカンマによってフィールドがずれてしまう件ですが、エクセル上で整形をしたので、コメントの列をすべてひとつの列の中にそろえましたので、もしもお手数になってしまうようでしたら、
コメントのカンマによってフィールドがずれてしまう問題に対応していなくても構いません。)


よろしくお願いします。

Public Sub DataExtract()

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntMark As Variant
  Dim strProm As String

  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '抽出する名前を取得
  With Worksheets("Sheet1")
    vntMark = .Range(.Cells(2, "E"), .Cells(Rows.Count, "E").End(xlUp).Offset(1)).Value
  End With
 
  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo
 
  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), dfo, vntMark
  Next i

  Close dfo
 
  strProm = "処理が完了しました"

Wayout:

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          dfo As Integer, _
          vntMark As Variant, _
          Optional strDelim As String = ",")

  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim i As Long
 
  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
     'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        'レコード中に、例えば「鈴木」という名前がある行を抽出
        For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i
        'もし指定文字列が有った場合
        If i <= UBound(vntMark, 1) - 1 Then
          '合成レコードを出力
          Print #dfo, strRec
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

エラーとして、
If vntField(0) <> "" Then の箇所にデバックが起こるか、プログラムは動いたが、何も書き出せれていないかです。

ご迷惑をおかけしております。

【67615】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 10/12/18(土) 9:59 -

引用なし
パスワード
   一番大きなミス?は、「Sub CSVRead」の中でSplitCsvの呼び出しを削除している事です
一見「Sub CSVRead」を使って無い様に見えるのですが、使ってますので消さないで下さい
後の変更は、各プロシージャの先頭に変更を書き込んで有ります
これで動かない様ならまた、その旨をUpして下さい

Option Explicit

Public Sub DataExtract_高校新人教師()

'  ★1、抽出件数表示の為の変数追加 2010-12-18
'  ★2、抽出Keyの記入忘れ対策の為、vntMarkの確認を追加 2010-12-18
'  ★3、CSVReadプロシージャの引数追加の対応の為 2010-12-18
'  ★4、抽出件数表示の為に変更 2010-12-18

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntMark As Variant
  Dim strProm As String
  Dim lngCount As Long '★1追加

  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '抽出する名前を取得
  With Worksheets("Sheet1")
    vntMark = .Range(.Cells(2, "E"), .Cells(Rows.Count, "E").End(xlUp).Offset(1)).Value
    If VarType(vntMark) <> vbArray + vbVariant Then '★2追加
      strProm = "探索Keyが設定されていません" '★2追加
      GoTo Wayout '★2追加
    End If '★2追加
  End With

  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo

  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), dfo, vntMark, lngCount '★3引数追加
  Next i

  Close dfo

  strProm = lngCount & "件の抽出処理が完了しました" '★4変更

Wayout:

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          dfo As Integer, _
          vntMark As Variant, _
          lngCount As Long, _
          Optional strDelim As String = ",")

'  ★1、引数にlngCountを追加 2010-12-18
'  ★2、SplitCsvの行が抜けているので追加 2010-12-18

  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim i As Long

  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        'レコード中に、例えば「鈴木」という名前がある行を抽出
        For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i
        'もし指定文字列が有った場合
        If i <= UBound(vntMark, 1) - 1 Then
          '合成レコードを出力
          Print #dfo, strRec
          '出力行数をカウント
          lngCount = lngCount + 1 '★2追加
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

【67730】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  高校新人教師  - 11/1/5(水) 19:34 -

引用なし
パスワード
   ▼高校新人教師 さん:
    ▼高校新人教師 さん:

>(データ整形で、数学と英語の平均点は、第5フィールド、第6フィールドでそろっていますので、コメント内の,によってフィールドがずれてしまう問題にはお手数でしたら、対応しなくても大丈夫です。)
このコードでは、先頭フィールドを0としている為、「数学と英語の平均点は、第4フィールド、第5フィールド」と成ります

Option Explicit

Public Sub DataExtract_高校新人教師()

'  ★1、抽出件数表示の為の変数追加 2010-12-18
'  ★2、抽出Keyの記入忘れ対策方法変更の為、vntMarkの確認を削除 2011-1-4
'  ★3、CSVReadプロシージャの引数追加の対応の為 2010-12-18
'  ★4、抽出件数表示の為に変更 2010-12-18
'  ★5、抽出Keyの記入忘れ対策の為、vntMarkの確認を追加 2011-1-4

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntMark As Variant
  Dim strProm As String
  Dim lngCount As Long '★1追加
  Dim vntTmp As Variant  '★5追加

  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '抽出する下限、上限値を取得
'  With Worksheets("Sheet1") '★2削除
'    vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value '★2削除
'    If VarType(vntMark) <> vbArray + vbVariant Then '★2削除
'      strProm = "探索Keyが設定されていません" '★2削除
'      GoTo Wayout '★2削除
'    End If '★2削除
'  End With '★2削除
  vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2) '★5追加
  For Each vntTmp In vntMark '★5追加
    If IsEmpty(vntTmp) Then '★5追加
      strProm = "探索Keyが設定されていません" '★5追加
      GoTo Wayout '★5追加
    End If '★5追加
  Next vntTmp '★5追加

  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo

  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), dfo, vntMark, lngCount '★3引数追加
  Next i

  Close dfo

  strProm = lngCount & "件の抽出処理が完了しました" '★4変更

Wayout:

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          dfo As Integer, _
          vntMark As Variant, _
          lngCount As Long, _
          Optional strDelim As String = ",")

'  ★1、引数にlngCountを追加 2010-12-18
'  ★2、SplitCsvの行が抜けているので追加 2010-12-18
'  ★3、フィールド数が一定に成った為、削除 2011-1-4
'  ★4、上記理由により変更 2011-1-4
'    (数学が4番目のフィールド、英語が5番目のフィールド)
'  ★5、抽出行数をカウントするコードを追加 2011-1-4

  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim i As Long
'  Dim lngMax As Long '★3削除

  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '★3、前回「自由コメント」に「,」が有る為、フィールド数が不定により
        '最終列を求め、後ろから何列目としたため必要としたので不必要
'        lngMax = UBound(vntField) '★3削除
        '数学の上下限で且つ英語の上下限に入るなら
        '★4、当然以下の行も変更
'        If vntMark(1, 1) <= Val(vntField(lngMax - 1)) _
'            And Val(vntField(lngMax - 1)) <= vntMark(1, 2) Then
'          If vntMark(2, 1) <= Val(vntField(lngMax)) _
'                    And Val(vntField(lngMax)) <= vntMark(2, 2) Then
        '数学の平均点(4番目のフィールド)が指定値以上なら
        If vntMark(1, 1) <= Val(vntField(4)) _
            And Val(vntField(4)) <= vntMark(1, 2) Then
          '英語の平均点(5番目のフィールド)が指定値以上なら
          If vntMark(2, 1) <= Val(vntField(5)) _
              And Val(vntField(5)) <= vntMark(2, 2) Then
            Print #dfo, strRec
            lngCount = lngCount + 1 '★5追加
          End If
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

【67731】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 11/1/5(水) 19:36 -

引用なし
パスワード
   ▼Hirofumi さん:
先ほど確認しましたところ、うまく抽出できました。
長い間、お付き合いくださいましてありがとうございました!
これから、自力で勉強していきながらも、また質問にお答えいただく機会がありましたらよろしくお願いします。

【67764】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 11/1/7(金) 3:35 -

引用なし
パスワード
        ▼Hirofumi さん:
先日は、対応ありがとうございました。
実は、書き出されたcsvファイルの中で、
フィールド1(0を第1列とする)には、
重複した文字列(英数字のみ)があるのですが、それらの重複のセル数をカウントして、別のファイルに書き出したいのですが、お力をお貸しください。

先日教えていただいた、コードをして、素人ながらおそらくFunction以降は変わらないのかなと思っているのですが、重複するデータを削除するようなプログラムはあるようですが、重複のセル数をカウントして、数を抽出する方法がわからないため、再度お聞きしたしだいです。

例えば、
field[1]
a
b
b
c
a
c
b
の場合、

field[1] field[2]
a, 2
b, 3
c, 2
のように書き出す。

【67766】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 11/1/7(金) 8:00 -

引用なし
パスワード
   配列変数を使った逐次探索で行うか?、配列変数の代わりにDictionaryを使った探索を
行えば出来ると思います
逐次探索より、Dictionaryの方が速そうなので此方でDataExtract_Count1を書きます

Option Explicit

Public Sub DataExtract_Count1()

'  Dictionaryを使用

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntKeys As Variant
  Dim dicIndex As Object
  Dim strProm As String
  
  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")

  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), dicIndex
  Next i

  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo

  With dicIndex
    'Dictionaryに登録して有る全てのKeyを取得
    vntKeys = .Keys
    '全てのKeyに就いて繰り返し
    For i = 0 To UBound(vntKeys)
      '出力ファイルに書き出し
      Print #dfo, vntKeys(i); ","; .Item(vntKeys(i))
    Next i
  End With
  
  Close dfo

  strProm = (UBound(vntKeys) + 1) & "件の抽出処理が完了しました"

Wayout:

  Set dicIndex = Nothing
  
  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          dicIndex As Object, _
          Optional strDelim As String = ",")

  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String

  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        With dicIndex
          'DictionaryにKeyとカウントを登録
          .Item(vntField(0)) = .Item(vntField(0)) + 1
        End With
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

ただ、Dictionaryが大抵は使えると思いますが?、使えない環境も有りますので
其の場合は逐次探索で行います

Option Explicit

Public Sub DataExtract_Count2()

'  配列を逐次探索

  Dim i As Long
  Dim vntInFiles As Variant
  Dim dfo As Integer
  Dim vntOutput As Variant
  Dim strPath As String
  Dim vntKeys() As Variant
  Dim lngMax As Long
  Dim strProm As String
  
  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path & "\"
  If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '出力ファイル名を取得
  If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  For i = 1 To UBound(vntInFiles)
    'データの読み込み
    CSVRead vntInFiles(i), vntKeys, lngMax
  Next i

  '出力ファイルをOpen
  dfo = FreeFile
  Open vntOutput For Output As dfo

  '配列に登録して有る全てのKeyに就いて繰り返し
  For i = 1 To lngMax
    '出力ファイルに書き出し
    Print #dfo, vntKeys(1, i); ","; vntKeys(2, i)
  Next i
  
  Close dfo

  strProm = lngMax & "件の抽出処理が完了しました"

Wayout:

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          vntKeys() As Variant, _
          lngMax As Long, _
          Optional strDelim As String = ",")

  Dim i As Long
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String

  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        'カウント用配列にvntField(0)の値が有るかを確認
        For i = 1 To lngMax
          If vntKeys(1, i) = vntField(0) Then
            Exit For
          End If
        Next i
        '無い場合
        If i > lngMax Then
          '配列を拡張
          lngMax = lngMax + 1
          ReDim Preserve vntKeys(1 To 2, 1 To lngMax)
          'Keyとカウントを登録
          vntKeys(1, lngMax) = vntField(0)
          vntKeys(2, lngMax) = 1
        Else
          'カウントを更新
          vntKeys(2, i) = vntKeys(2, i) + 1
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

  Close #dfn

End Sub

【67845】Re:特定の範囲内の値をもつ行を抽出しコ...
お礼  高校新人教師  - 11/1/13(木) 4:45 -

引用なし
パスワード
   ▼Hirofumi さん:
Dictionaryの方が速く抽出できました。
どちらもできるようお気をつかってくださいましてありがとうございました。

【67846】Re:特定の範囲内の値をもつ行を抽出しコ...
質問  高校新人教師  - 11/1/13(木) 4:58 -

引用なし
パスワード
   ▼Hirofumi さん:
こちらのいくつかのCSVファイルから鈴木という名前のような、特定の文字列を含む行を抽出するものでしたが、

Private Sub CSVRead 内で、

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti) '★1この行が無い
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      If vntField(0) <> "" Then
        '配列変数vntFieldは、vntField(0):氏名、vntField(1):クラス
        '・・vntField(5):数学の平均点、vntField(6):英語の平均点と成ります
        'レコード中に、例えば「鈴木」という名前がある行を抽出
        For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i
        'もし指定文字列が有った場合
        If i <= UBound(vntMark, 1) - 1 Then
          '合成レコードを出力
          Print #dfo, strRec
          '出力行数をカウント
          lngCount = lngCount + 1 '★2追加
        End If
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbCrLf
    End If
  Loop

の箇所では、E列に指定したいくつかの文字列を、指定形式のファイル内での1行に関して、全てのFieldに検索をしていただいていると思うのですが、
例えば、Field(1)のみ、または、Field(1)とField(2)のように検索するフィールドを指定したいのですが、
うまくいかずというかわからないのでご質問いたしました。

For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i


以上の箇所を書き換えていけばよいのかと思うのですが、

何度も質問してしまい申し訳ありません。

【67847】Re:特定の範囲内の値をもつ行を抽出しコ...
回答  Hirofumi  - 11/1/13(木) 9:40 -

引用なし
パスワード
           For i = 1 To UBound(vntMark, 1) - 1
          '名前若しくはコメントの中に指定した文字列在る場合
          If InStr(1, strRec, vntMark(i, 1), vbBinaryCompare) > 0 Then
            'Forを抜ける
            Exit For
          End If
        Next i

と有る中で、vntMark(i, 1)は探す文字列で、探される文字列は上記の場合 、strRecです
strRecは、カンマで分割される前の1レコード分の文字列です
此処で、

>例えば、Field(1)のみ、または、Field(1)とField(2)のように検索するフィールドを
>指定したいのですが、

と言う事なら、このstrRecを例えば、「Field(1)のみ」なら

          If InStr(1, vntField(1), vntMark(i, 1), vbBinaryCompare) > 0 Then

とします
また、「vbBinaryCompare」大文字、小文字、全角、半角を区別していますが?
此れを、「vbTextCompare」とすれば、区別しないで探します

2471 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free