Excel VBA質問箱 IV

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

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


14498 / 76734 ←次へ | 前へ→

【67730】Re:特定の範囲内の値をもつ行を抽出しコピーする方法(CSVファイル)
回答  高校新人教師  - 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
1 hits

【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 お礼

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