Excel VBA質問箱 IV

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

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


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

【27411】ファイルの場所の特定方法について ひな 05/8/8(月) 18:05 質問[未読]
【27420】Re:ファイルの場所の特定方法について Hirofumi 05/8/8(月) 21:08 回答[未読]

【27411】ファイルの場所の特定方法について
質問  ひな  - 05/8/8(月) 18:05 -

引用なし
パスワード
   ファイルの場所の特定方法について教えて下さい。

1つのフォルダの中にある「test」で始まる全ファイルの特定の
セル範囲を別ブックにコピーしたいのですが・・・

今、以下のように書いてみたのですがエラーになってしまいます。
(ファイル名を選択するよう促されます。)

******************************

'パス名定義
path_name = "C:〜"

'上記フォルダに保存されている
'"test*.xls"ファイルを検索しファイル名を取得
Set fs = Application.FileSearch
With fs
  .LookIn = path_name
  .Filename = "test*.xls"
  If .Execute > 0 Then
    For i = 1 To .FoundFiles.Count
      file_name = .FoundFiles(i)
      If file_name Like "*test_a*" Then
        file_a = Dir(file_name)
      ElseIf file_name Like "*test_b*" Then
        file_b = Dir(file_name)
      ElseIf file_name Like "*test_c*" Then
        file_c = Dir(file_name)
      End If
    Next i
  End If
End With
  
'フルパス設定
full_path = path_name & "\" & "[" & file_audio & "]"

'上記ファイルの"sheet1"のA列を別ブックのA2以降にコピー
'With ThisWorkbook.Worksheets("sheet1").Range("A2:A65536")
  .Formula = "=if(" & _
      "'full_path!sheet1'!A1=" & _
      """"",""""," & _
      "'full_path!sheet1'!A1)"
  .Value = .Value
End With

******************************

どうしたらよいでしょうか?
上記方法でなくても、他にやり方があれば教えて下さい。
宜しくお願いします。

【27420】Re:ファイルの場所の特定方法について
回答  Hirofumi  - 05/8/8(月) 21:08 -

引用なし
パスワード
   善く解らないけど、こなので善いのかな?
尚、

  '読み込むファイルを取得
  If Not GetFilesList(vntFileNames, strPath, objFso, _
                    "xls", "test*") Then

の所で、Folderからファイル名を取得していますが
GetFilesListの第4引数("xls")が拡張子を
GetFilesListの第5引数("test*") がファイル名を決めています
記述は、正規表現を使用していますので、正規表現の書き方で記述して下さい

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub Posting()

  'Copyする列数
  Const clngColumns As Long = 1
  
  Dim i As Long
  Dim strPath As String
  Dim vntFileNames As Variant
  Dim wkbMark As Workbook
  Dim rngResult As Range
  Dim lngRows As Long
  Dim lngRow As Long
  Dim objFso As Object
  Dim strProm As String
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  'パス名定義
'  strPath ="C:〜"
  strPath = ThisWorkbook.Path & "\TestData"
  
  '読み込み指定されたFolderの確認、変更(必要無ければDo〜Loopまで消して下さい)
  Do
    strPath = InputBox("読み込むファイルの有るPathを入力して下さい", , strPath)
    If strPath = "" Then
      strProm = "マクロがキャンセルされました"
      GoTo Wayout
    Else
      If objFso.FolderExists(strPath) Then
        Exit Do
      Else
        Beep
        MsgBox strPath & " は存在しません"
      End If
    End If
  Loop
  
  '読み込むファイルを取得
  If Not GetFilesList(vntFileNames, strPath, objFso, _
                    "xls", "test*") Then
    strProm = "読み込むファイルが有りません"
    GoTo Wayout
  End If
  
  '出力する位置を指定
  Set rngResult = ActiveWorkbook.Worksheets("Sheet1").Cells(1, "A")
  lngRow = 1
  
  Application.ScreenUpdating = False
  
  'Bookデータの読み込み
  For i = 1 To UBound(vntFileNames)
    '指定BookをOpen
    Set wkbMark = Workbooks.Open(vntFileNames(i))
    With wkbMark.Worksheets("Sheet1").Cells(1, "A")
      'データ行数を取得
      lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
      'データが有る場合
      If Not (lngRows <= 1 And .Value = "") Then
        'Copyして、指定シートに張り付け
        .Resize(lngRows, clngColumns).Copy _
            Destination:=rngResult.Offset(lngRow)
        '張り付け位置を更新
        lngRow = lngRow + lngRows
      End If
    End With
    '指定BookをClose
    wkbMark.Close SaveChanges:=False
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set objFso = Nothing
  Set rngResult = Nothing
  Set wkbMark = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Function GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              objFso As Object, _
              Optional regExtePattan As String = ".*", _
              Optional strNamePattan 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 = regExtePattan
    '大文字と小文字を区別しないように設定
    .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
    ShellSort vntRead
    ReDim vntFileNames(1 To UBound(vntRead))
    For i = 1 To UBound(vntRead)
      vntFileNames(i) _
          = strFilePath & "\" & vntRead(i)
    Next i
    GetFilesList = True
  End If
  
Wayout:

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

Private Sub ShellSort(vntList As Variant)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim vntTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap <= 0
    For i = lngGap + lngTop To lngEnd
      vntTmp = vntList(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(j - lngGap) <= vntTmp Then
          Exit For
        End If
        vntList(j) = vntList(j - lngGap)
      Next j
      vntList(j) = vntTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

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