Excel VBA質問箱 IV

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

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


14866 / 76734 ←次へ | 前へ→

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

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

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