Excel VBA質問箱 IV

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

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


14463 / 76734 ←次へ | 前へ→

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

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

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