Excel VBA質問箱 IV

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

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


8436 / 13644 ツリー ←次へ | 前へ→

【33137】外部ファイルの条件選択について みり 06/1/3(火) 15:59 質問[未読]
【33138】Re:外部ファイルの条件選択について かみちゃん 06/1/3(火) 16:07 発言[未読]
【33139】Re:外部ファイルの条件選択について かみちゃん 06/1/3(火) 16:23 回答[未読]
【33157】Re:外部ファイルの条件選択について Hirofumi 06/1/3(火) 19:52 回答[未読]
【33174】Re:外部ファイルの条件選択について みり 06/1/4(水) 16:20 質問[未読]
【33179】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 17:32 回答[未読]
【33184】Re:外部ファイルの条件選択について みり 06/1/4(水) 18:24 質問[未読]
【33188】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 18:44 発言[未読]
【33196】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 20:38 回答[未読]
【33198】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 20:45 発言[未読]
【33297】Re:外部ファイルの条件選択について みり 06/1/7(土) 19:00 質問[未読]
【33298】Re:外部ファイルの条件選択について Hirofumi 06/1/7(土) 21:52 回答[未読]

【33137】外部ファイルの条件選択について
質問  みり  - 06/1/3(火) 15:59 -

引用なし
パスワード
   よろしくお願いします。

現在、txtファイルの読込をダイアログで選択し行っています。
ファイル名はyymmdd.txtの形式になります。
フォルダ場所は C:\list です。
パスはC:\list\yymmdd.txtになります。

エクセルのB3に予め2005/10〜2005/12という具合に期間を記載してあるため
この日付を利用しファイルをまとめて選択したいのですが
どのような方法が良いでしょうか

ご指導をお願いします。

【33138】Re:外部ファイルの条件選択について
発言  かみちゃん E-MAIL  - 06/1/3(火) 16:07 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>エクセルのB3に予め2005/10〜2005/12という具合に期間を記載してあるため
>この日付を利用しファイルをまとめて選択したい

B3に、
2005/10〜2005/12
と記載されていたら、
051001.txt、051002.txt・・・051230.txt、051231.txt
というファイルを選択したいということですか?
なお、ここでいう選択というのは、どういうことですか?
順番にファイルを開きたいなど選択して何かしたいというところを具体的に説明してください。

【33139】Re:外部ファイルの条件選択について
回答  かみちゃん E-MAIL  - 06/1/3(火) 16:23 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>エクセルのB3に予め2005/10〜2005/12という具合に期間を記載してあるため
>>この日付を利用しファイルをまとめて選択したい
>
>B3に、
>2005/10〜2005/12
>と記載されていたら、
>051001.txt、051002.txt・・・051230.txt、051231.txt
>というファイルを選択したいということですか?

ファイル名を生成するだけでしたら、以下のような感じになります。

Sub Macro1()
 Dim StartDate As Date
 Dim EndDate As Date
 Dim TargetDate As Date
 Dim strFileName As String
 Const strPath As String = "C:\list\"
  
 '処理開始日
 StartDate = DateValue(Split(Range("B3").Value, "〜")(0) & "/1")
 '処理終了日(翌月の1日の前日)
 EndDate = DateValue(Format(DateAdd("m", 1, DateValue(Split(Range("B3").Value, "〜")(1) & "/28")), "yyyy/mm/01")) - 1
 TargetDate = StartDate
 Do While TargetDate <= EndDate
  '対象期間のファイル名を生成
  strFileName = strPath & Format(TargetDate, "yymmdd"".txt""")
  '生成したファイル名をイミディエイトウィンドウに表示
  Debug.Print strFileName
  
  TargetDate = TargetDate + 1
 Loop
 MsgBox "処理終了"
End Sub

【33157】Re:外部ファイルの条件選択について
回答  Hirofumi  - 06/1/3(火) 19:52 -

引用なし
パスワード
   かみちゃんさんと同じ様な物ですが?
「Private Function GetFilesList」が指定フォルダの
「yymmdd.txt」形式のファイル名を配列で返してきます

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim rngResult As Range
  Dim vntFileNames As Variant
  Dim strPath As String
  Dim vntDate As Variant
  Dim strProm As String
  
  'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngResult = ActiveSheet.Cells(3, "B")
  vntDate = rngResult.Value
  
  'フォルダ名を指定
  strPath = "C:\list"

  '読み込むファイル名を取得(指定フォルダから取得)
  If Not GetFilesList(vntFileNames, strPath, vntDate) Then
    GoTo Wayout
  End If
    
  For i = 1 To UBound(vntFileNames, 1)
    rngResult.Offset(i + 4).Value = vntFileNames(i)
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              vntMark As Variant) As Boolean
  
  Dim i As Long
  Dim vntRead() As Variant
  Dim strName As String
  Dim objFso As Object
  Dim lngPos As Long
  Dim vntStart As Variant
  Dim vntFinish As Variant
  Dim lngCount As Long
  
  vntMark = Trim(vntMark)
  lngPos = InStr(1, vntMark, "〜", vbBinaryCompare)
  If lngPos = 0 Then
    GoTo Wayout
  End If
  '開始日付の取得
  vntStart = Left(vntMark, lngPos - 1)
  If IsDate(vntStart) Then
    vntStart = DateValue(vntStart)
  Else
    GoTo Wayout
  End If
  '終了日付の取得
  vntFinish = Mid(vntMark, lngPos + 1)
  If IsDate(vntFinish) Then
    vntFinish = DateValue(vntFinish)
    vntFinish = DateSerial(Year(vntFinish), _
                Month(vntFinish) + 1, 0)
  Else
    GoTo Wayout
  End If
    
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
    
  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If
   
  'ファイルの存在確認
  For i = vntStart To vntFinish
    strName = strFilePath & "\" & Format(i, "yymmdd") & ".txt"
    If objFso.FileExists(strName) Then
      lngCount = lngCount + 1
      ReDim Preserve vntRead(1 To lngCount)
      vntRead(lngCount) = strName
    End If
  Next i
  
  'ファイルの数が0でなければ
  If lngCount > 0 Then
    vntFileNames = vntRead
    GetFilesList = True
  End If
      
Wayout:

  'フォルダオブジェクトを破棄
  Set objFso = Nothing
  
End Function

【33174】Re:外部ファイルの条件選択について
質問  みり  - 06/1/4(水) 16:20 -

引用なし
パスワード
   かみちゃん様、Hirofumi様 ありがとうございます。
動作確認をさせて頂きました。

過去の検索をし、Hirofumi様の外部データの取り込みマクロを
改造してみました。
ダイアログを表示させてファイルを選択すれば動作します。

これに今回ご提示頂いたマクロを組み込み、ダイアログによる選択を無くすには
どのようにすればよいかが分かりません。

ご指導をお願い致します。


Public Sub データ表示()

  '日付の先頭位置の前の列
  Const clngTop As Long = 13

  Dim strPath As String
  Dim vntFileName As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim lngRow As Long
  Dim rngScope As Range
  Dim rngResult As Range
  Dim rngDate As Range
  Dim strProm As String
  Dim strNoMatch As String
  Dim A As String

  'Textファイルの有るフォルダを指定
  strPath = "C:\list"

  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする
  Set rngResult = Worksheets("フォーマット").Cells(8, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    '日付列の範囲を取得
    If lngCol > 0 Then
      Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
    Else
      strProm = "日付列が有りません。"
      GoTo Wayout
    End If
    'No.が有る行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'No.が有る範囲を取得
    If lngRow > 0 Then
      Set rngScope = .Offset(1).Resize(lngRow)
    End If
  End With

  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '「20050731」形式の日付をシリアル値に変換
    vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))

        'No.を探索
      lngRow = GetTagNoRow(vntField(4), rngScope, rngResult)
      '行位置が見つかったら
      If lngRow > 0 Then
        '日付を探索
        lngCol = GetDateColumn(vntField(0), rngDate, _
                  rngResult.Offset(, clngTop)) + clngTop
      If lngCol = 0 + clngTop Then
      '該当日付が無い場合、メセージを出し直ちに終了する
      strProm = Format(vntField(0), "m/d") & " の日付が有りません。"
      GoTo Wayout
      End If
        '日付、Noの交差するセルに値を書き込み
        With rngResult.Offset(lngRow, lngCol)
          .NumberFormatLocal = "G/標準"
          .Value = vntField(5)
        End With
        
        A = vntField(1)
        rngResult.Offset(2, lngCol).Value = Left(A, 2) & ":" & Right(A, 2)
        
      End If
    Loop

  If strNoMatch = "" Then
    strProm = "処理が完了しました"
  Else
    strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
  End If
  
Wayout:

  Close #dfn
 
  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing

  Beep
  MsgBox strProm

End Sub

Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long

  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope)
    'セル値が文字列として入力されている場合
'    lngFound = DateSearch(vntDate, rngScope)
  End If

  GetDateColumn = lngFound

End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Variant

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
  Else
    'Noを探索
    lngFound = DataSearch(CLng(vntTagNo), rngScope, , 0)
  End If

  '位置を返す
  GetTagNoRow = lngFound

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function

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

  Dim strFilter As String

  'フィルタ文字列を作成
  strFilter = "Text File (*.txt),*.txt,"
  
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
    = Application.GetOpenFilename(strFilter, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If

  GetReadFile = True

End Function

【33179】Re:外部ファイルの条件選択について
回答  Hirofumi  - 06/1/4(水) 17:32 -

引用なし
パスワード
   >これに今回ご提示頂いたマクロを組み込み、ダイアログによる選択を無くすには
>どのようにすればよいかが分かりません。
>
>ご指導をお願い致します。

1、まず、みりさんが、「- 06/1/4(水) 16:20 -」にUpされたコードと同じ標準モジュールに、
 「Private Function GetFilesList」をCopyします
2、ダイアログ表示はし無いので「Private Function GetReadFile」は削除します
3、以下のプロシージャは、其のまま使います
 「Function GetDateColumn」
 「Function GetTagNoRow」
 「Function DataSearch」
4、以下の様にコードを変更します

尚、データが無いのでTestはしておりませんので宜しく

Public Sub データ表示()

  '日付の先頭位置の前の列
  Const clngTop As Long = 13

  Dim strPath As String
  Dim vntFileName As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim lngRow As Long
  Dim rngScope As Range
  Dim rngResult As Range
  Dim rngDate As Range
  Dim strProm As String
'  Dim strNoMatch As String '★削除
  Dim A As String
  Dim i As Long '◎追加
  Dim vntDate As Variant '◎追加

  'Textファイルの有るフォルダを指定
  strPath = "C:\list"

  '★以下の5行削除
'  '「ファイルを開く」ダイアログを表示
'  If Not GetReadFile(vntFileName, strPath, False) Then
'    strProm = "マクロがキャンセルされました"
'    GoTo Wayout
'  End If
  
  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする
  Set rngResult = Worksheets("フォーマット").Cells(8, "A")
  With rngResult
    '抽出日付を取得(B3のセル位置) ◎追加
    vntDate = .Offset(-5, 1).Value '◎追加
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    '日付列の範囲を取得
    If lngCol > 0 Then
      Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
    Else
      strProm = "日付列が有りません。"
      GoTo Wayout
    End If
    'No.が有る行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'No.が有る範囲を取得
    If lngRow > 0 Then
      Set rngScope = .Offset(1).Resize(lngRow)
    End If
  End With

  'フォルダから指定日付のファイル名を取得 ◎追加
  If Not GetFilesList(vntFileName, strPath, vntDate) Then '◎追加
    strProm = "指定日付のファイルが有りません" '◎追加
    GoTo Wayout '◎追加
  End If '◎追加

  '取得したファイル名分繰り返し ◎追加
  For i = 1 To UBound(vntFileName) '◎追加
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileName(i) For Input As dfn '☆変更
    'ファイルEndまで繰り返し
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '「20050731」形式の日付をシリアル値に変換
      vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                  & "/" & Mid(vntField(0), 5, 2) _
                  & "/" & Right(vntField(0), 2)))
      'No.を探索
      lngRow = GetTagNoRow(vntField(4), rngScope, rngResult)
      '行位置が見つかったら
      If lngRow > 0 Then
        '日付を探索
        lngCol = GetDateColumn(vntField(0), rngDate, _
                  rngResult.Offset(, clngTop)) + clngTop
        If lngCol = 0 + clngTop Then
          '該当日付が無い場合、メセージを出し直ちに終了する
          strProm = Format(vntField(0), "m/d") & " の日付が有りません。"
          Close #dfn '◎追加
          GoTo Wayout
        End If
        '日付、Noの交差するセルに値を書き込み
        With rngResult.Offset(lngRow, lngCol)
          .NumberFormatLocal = "G/標準"
          .Value = vntField(5)
        End With
        A = vntField(1)
        rngResult.Offset(2, lngCol).Value = Left(A, 2) & ":" & Right(A, 2)
      Else '◎追加
        '該当Itemが無い場合、メセージを出し直ちに終了する ◎追加
        strProm = vntField(4) & " のItemが有りません。" '◎追加
        Close #dfn '◎追加
        GoTo Wayout '◎追加
      End If
    Loop
    Close #dfn '◎追加
  Next i '◎追加
  
  '★以下の5行削除
'  If strNoMatch = "" Then
'    strProm = "処理が完了しました"
'  Else
'    strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
'  End If
 
  strProm = "処理が完了しました" '◎追加
 
Wayout:

'  Close #dfn '★削除

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing

'  Beep '★削除
  MsgBox strProm, vbInformation '☆変更

End Sub

【33184】Re:外部ファイルの条件選択について
質問  みり  - 06/1/4(水) 18:24 -

引用なし
パスワード
   Hirofumi 様 お蔭さまで無事に動作をしております。
とても助かりました。

もう一つ質問があるのですが
現在のデータ形式 yymmdd.txt に加え
下記の様なファイル形式も同時に認識をさせたく思います。
yymmdd_1.txt、yymmdd_2.txt、・・・

strName = strFilePath & "\" & Format(i, "yymmdd") & "*txt"
で出来るかなと思いましたがダメでした。
何卒、ご指導をお願い致します。

【33188】Re:外部ファイルの条件選択について
発言  Hirofumi  - 06/1/4(水) 18:44 -

引用なし
パスワード
   >もう一つ質問があるのですが
>現在のデータ形式 yymmdd.txt に加え
>下記の様なファイル形式も同時に認識をさせたく思います。
>yymmdd_1.txt、yymmdd_2.txt、・・・
>
>strName = strFilePath & "\" & Format(i, "yymmdd") & "*txt"
>で出来るかなと思いましたがダメでした。
>何卒、ご指導をお願い致します。

多分、単純には行かないと思います
1、Dir関数を使えば、ある程度簡単に成りますが、Dir関数の欠点が出るのが怖いし
2、Fsoを使うと、コードが複雑に成りそうだし、遅く成りそう

上記で少し考えて見ます

【33196】Re:外部ファイルの条件選択について
回答  Hirofumi  - 06/1/4(水) 20:38 -

引用なし
パスワード
   前の「Function GetFilesList」を削除して
以下の2つのプロシージャと入れ替えてください
ただし、ファイル名の抽出は遅く成ると思います

Private Function GetFilesList(vntFilenames As Variant, _
                strPath As String, _
                vntMark As Variant) As Boolean
  
'  Fso使用版
  
  Dim i As Long
  Dim j As Long
  Dim vntRead() As Variant
  Dim strName As String
  Dim lngPos As Long
  Dim vntStart As Variant
  Dim vntFinish As Variant
  Dim lngCount As Long
  Dim vntFiles As Variant
  Dim strCompe As String
  Dim objFso As Object
  
  vntMark = Trim(vntMark)
  lngPos = InStr(1, vntMark, "〜", vbBinaryCompare)
  If lngPos = 0 Then
    GoTo Wayout
  End If
  '開始日付の取得
  vntStart = Left(vntMark, lngPos - 1)
  If IsDate(vntStart) Then
    vntStart = DateValue(vntStart)
  Else
    GoTo Wayout
  End If
  '終了日付の取得
  vntFinish = Mid(vntMark, lngPos + 1)
  If IsDate(vntFinish) Then
    vntFinish = DateValue(vntFinish)
    vntFinish = DateSerial(Year(vntFinish), _
                Month(vntFinish) + 1, 0)
  Else
    Exit Function
  End If
    
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
     
  '指定形式のファイル名を取得
  strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
  If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt") Then
    GoTo Wayout
  End If

  'ファイル名の比較
  For i = vntStart To vntFinish
    '比較パターンを作成
    strName = Format(i, "yymmdd") & "*"
    '抽出したファイル名と比較
    For j = 1 To UBound(vntFiles)
      If objFso.GetBaseName(vntFiles(j)) Like strName Then
        lngCount = lngCount + 1
        ReDim Preserve vntRead(1 To lngCount)
        vntRead(lngCount) = vntFiles(j)
      End If
    Next j
  Next i
  
  'ファイルの数が0でなければ
  If lngCount > 0 Then
    vntFilenames = vntRead
    GetFilesList = True
  End If
  
Wayout:

  Set objFso = Nothing

End Function

Private Function GetFileNames(vntFilenames As Variant, _
              strFilePath As String, _
              objFso As Object, _
              Optional strNamePattan As String = ".*", _
              Optional strExtePattan As String = ".*") As Boolean

  Dim i As Long
  Dim objFiles As Object
  Dim objFile As Object
  Dim regExten As Object
  Dim regName As Object
  Dim vntRead() As Variant
  Dim strName As String

  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If

  'regExtenpのオブジェクトを取得(正規表現を作成)
  Set regExten = CreateObject("VBScript.RegExp")
  With regExten
    'パターンを設定
    .Pattern = strExtePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
  Set regName = CreateObject("VBScript.RegExp")
  With regName
    'パターンを設定
    .Pattern = strNamePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With

  'フォルダオブジェクトを取得
  Set objFiles = objFso.GetFolder(strFilePath).Files

  'ファイルの数が0でなければ
  If objFiles.Count <> 0 Then
    For Each objFile In objFiles
      With objFile
        strName = .Name
        '検索をテスト
        If regExten.TEST(objFso.GetExtensionName(strName)) Then
          If regName.TEST(objFso.GetBaseName(strName)) Then
            i = i + 1
            ReDim Preserve vntRead(1 To i)
            vntRead(i) = strName
          End If
        End If
      End With
    Next objFile
  End If

  Set regExten = Nothing
  Set regName = Nothing

  If i <> 0 Then
    ReDim vntFilenames(1 To UBound(vntRead))
    For i = 1 To UBound(vntRead)
      vntFilenames(i) _
        = StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
    Next i
    GetFileNames = True
  End If

Wayout:

  'フォルダオブジェクトを破棄
  Set objFiles = Nothing
  Set objFile = Nothing

End Function

【33198】Re:外部ファイルの条件選択について
発言  Hirofumi  - 06/1/4(水) 20:45 -

引用なし
パスワード
   尚、「Hirofumi - 06/1/3(火) 19:52 - 」の「Sub Sample」を使えば
何が抽出されるかTestで来ます

【33297】Re:外部ファイルの条件選択について
質問  みり  - 06/1/7(土) 19:00 -

引用なし
パスワード
   Hirofumi様 ありがとうございました。
いろいろとテストさせていただきました。
とても良好です。

今、strPathにサブフォルダが存在する場合、
そこもデータ取得の対象にする為に取り組んでいます。
何卒、ヒントだけでも教えて頂きたくお願い致します。

【33298】Re:外部ファイルの条件選択について
回答  Hirofumi  - 06/1/7(土) 21:52 -

引用なし
パスワード
   現在の「Private Function GetFileNames」を削除して
以下の2つのプロシージャと差し替えて下さい

Private Function GetFileNames(vntFileNames As Variant, _
              strFolderPath As String, _
              objFSO As Object, _
              Optional strBasePattan As String = ".*", _
              Optional strExtePattan As String = ".*", _
              Optional lngSubDir As Long = -1) As Boolean
              
  Const clngLower As Long = 0
  
  Dim regName As Object
  Dim vntRead As Variant
  
  'フォルダの存在確認
  If Not objFSO.FolderExists(strFolderPath) Then
    GoTo Wayout
  End If
  
  Set regName = CreateObject("VBScript.RegExp")
  '大文字と小文字を区別しないように設定
  regName.IgnoreCase = True

  'ファイル名List配列の初期化
  ReDim vntRead(1, clngLower To 1)
  'ファイル名Listの作成
  GetFilePath vntRead, _
        objFSO.GetFolder(strFolderPath), _
        strBasePattan, strExtePattan, _
        regName, objFSO, lngSubDir
  
  'ファイル名List配列の先頭値が""で無いなら
  If vntRead(0, clngLower) <> "" Then
    vntFileNames = vntRead
    GetFileNames = True
  End If
  
Wayout:
  
  Set regName = Nothing

End Function

Private Sub GetFilePath(vntFileNames As Variant, _
            objFolder As Object, _
            strBasePattan As String, _
            strExtePattan As String, _
            regName As Object, _
            objFSO As Object, _
            ByVal lngSubDir As Long)

  Dim lngLower As Long
  Dim i As Long
  Dim objFile As Object
  Dim objSubDir As Object
  Dim strDirPath As String
  Dim strName As String
  
  'List配列の最小添え字を取得
  lngLower = LBound(vntFileNames, 2)
  'List配列に値が有る場合
  If vntFileNames(0, lngLower) <> "" Then
    'カウンタをList配列の最大添え字に設定
    i = UBound(vntFileNames, 2)
  Else
    'カウンタをList配列の最小添え字以下に設定
    i = lngLower - 1
  End If
  
  '現在のFoderPathを取得
  strDirPath = objFolder.Path & "\"
  'ファイル名を列挙
  For Each objFile In objFolder.Files
    strName = objFile.Name
    With regName
      '拡張子を比較
      .Pattern = strExtePattan
      If .TEST(objFSO.GetExtensionName(strName)) Then
        'Base名を比較
        .Pattern = strBasePattan
        If .TEST(objFSO.GetBaseName(strName)) Then
          'カウンタをインクリメント
          i = i + 1
          'List配列を拡張
          ReDim Preserve vntFileNames(1, lngLower To i)
          'Path、ファイル名を代入
          vntFileNames(0, i) = strDirPath
          vntFileNames(1, i) = strName
        End If
      End If
    End With
  Next objFile

  Set objFile = Nothing
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '階層指定を一つ下げる
    lngSubDir = lngSubDir - 1
    'SubFolderを探索
    For Each objSubDir In objFolder.SubFolders
      GetFilePath vntFileNames, objSubDir, _
            strBasePattan, strExtePattan, _
            regName, objFSO, lngSubDir
    Next objSubDir
  End If
  
  Set objSubDir = Nothing
  
End Sub

後、呼び出し側の「Private Function GetFilesList」に就いて
もし、指定Folrder以下のSubFolrder全てなら、「Private Function GetFilesList」を
変更せず其のままで出来ます
また、指定Folrderの直ぐ下のFolderまでなら以下の様に変更して下さい

「Private Function GetFilesList」の中の

  '指定形式のファイル名を取得
  strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
  If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt") Then
    GoTo Wayout
  End If



  '指定形式のファイル名を取得
  strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
  If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt", 1) Then
    GoTo Wayout
  End If

にする
新しい、「Private Function GetFileNames」は、引数が1つ増え、
最後の引数がSubFolderの階層を指定しています
意味は、0=指定Folder、1=指定Folder因り1つ下まで、2=指定Folder因り2つ下まで、・・・
尚、ここに-1を指定するか、何も指定しない場合、
指定Folder以下全てのSubFilderが対象と成ります

尚、このコードは、再帰呼び出しを使って居ますので
多分相当遅く成ると思います
また、再帰の常で、余り深い階層に成るとスッタクオーバーと成りますので、
気を就けて下さい
ただ、Win98でも3〜4層した程度なら使えると思います
(WinXP、Win2000のOSならもっと下まででも行けると思いますが、
くれぐれも、「C:\以下全て」の様な使い方をし無い方が無難です)

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