初心者のExcel2003VBA フォルダの質問

質問

http://okwave.jp/qa/q7635479.htmlでお世話になった者です

その後教えてもらったコードを何度も読み直しながら加工したりしていたのですが
やはりというか、また躓いてしまいました

現状：
　・aシートは検索用シートで、日によって異なる数のIDを入力する列(仮にA列)があり
　　コマンドボタン１を押すと入力された各ID行の指定列に各リンク先が表示される
　・欲しいリンク先はExcelシートとフォルダとがあり、Excelシートからのリンク先の抽出は出来ている

予定：
　・社内サーバに保管されている他部署管理のフォルダ(基フォルダ)の中にある
　　「ID番号を含む名前のついたフォルダ」へのパスを、検索用シートの各ID行の指定列に貼り付けたい
　・基フォルダ内には5つのカテゴリ分けされたフォルダがあり、欲しいパスはカテゴリのどれかの中の
　　さらに日付毎に作成されたサブフォルダ(1500～2500)内にあり、更新頻度は欲しいフォルダごとにバラバラ
　・欲しいフォルダには下位フォルダとして、zipフォルダも含まれる(この中のデータが欲しい時もあり)
　・コマンドボタン2を押すと、抽出された各リンク先からファイルやフォルダを、日付の名前で作成された
　　新規フォルダに保存する

　基フォルダ内にある5つのカテゴリフォルダの内3つについてはほとんど使用頻度がないので、メインでは
　2つのフォルダに絞られます。また、入力されたIDの桁数(5桁以下・6桁以上)によって残り二つのどちらを使うかが決められるので、そこを条件分岐にしてみようと思いました

↓教えてもらったコード

For i = 1 To ipCnt
tpStr = ipAry(i) & "_*"

For j = idcnt To 1 Step -1
If idAry(j) Like tpStr Then

lkRng.Cells(j, 1).Copy
rtRng.Cells(i, 1).PasteSpecial Paste:=xlPasteValues

lfRng.Cells(j, 1).Copy
rfRng.Cells(i, 1).PasteSpecial Paste:=xlPasteValues

Exit For
ここまでの宣言については問題ありませんでした

'+-------------------------
付け足した・作成したコード

(1)
'フォルダを探す
With Application.FileSearch
.NewSearch '入力されたIDの桁数によって参照先を替えて　さらにそのパスの後ろに検索用としてIDとワイルドカードをつける
If Len(i) <= "5" Then
dirname = Dir("「カテゴリフォルダ1へのパス」\*" & i & "_*", vbDirectory)
Else
dirname = Dir("「カテゴリフォルダ2へのパス」\*" & i & "_*", vbDirectory)
End If

'エラー処理用
If tpStr = "" Or tpStr = "False" Then Exit Sub

.Filename = tpStr 'tpStrはIDの後ろにワイルドカードをつけた値の入っている変数　検索用
' tpStr = GetFolder(dirname)　'同じ変数で処理をしたくて
.LookIn = tpStr
.SearchSubFolders = True 'サブフォルダも検索する

　 End If
End With
Set FSO = Nothing
'ここまで自作
'+-----------------------
End If

'次の検索IDを調べる
Next j
End With
　Next i

If Not ckFlg Then dtBok.Close
Application.Calculation = xlCalculationAutomatic

End Sub

Sub 自動再計算ON()
Application.Calculation = xlCalculationAutomatic
End Sub
+--------------------

試行錯誤しながら相次ぐエラーで修正したり消したりしていたらどんどん短くなってしまいました
現状、コマンドボタン１を押すと何事もなく終了してしまいます・・・

↓別で作った新規フォルダ作成・コピーファイル保存用モジュール(自作)
+--------------------
Sub DATA_Get_MACRO()
Dim myFSO, objFSO As Object
Dim File_PathA, File_PathB, File_PathC, File_PathD, File_PathE, File_PathF, File_PathG, File_PathH, File_PathI, File_PathJ, File_PathK, File_PathL, File_PathM, File_PathN, File_PathO, File_PathP, myFolderA, myFolderB, myFolderC, myFolderD, myFolderE As String
Dim Count_RowA, Count_RowB As Long
'+----------------------
'新規フォルダの作成
Set objFSO = CreateObject("Scripting.FileSystemObject")
DT_Date = Format(Now(), "yymmdd")
myFolderA = ThisWorkbook.Path & "フォルダパス名"
myFolderB = ThisWorkbook.Path & "フォルダパス名&下位フォルダ名"
myFolderC = ThisWorkbook.Path & "フォルダパス名&下位フォルダ名" & Date
myFolderL = ThisWorkbook.Path & "フォルダパス名&下位フォルダ名" & Date & "Excelシート用フォルダ名"
myFolderF = ThisWorkbook.Path & "フォルダパス名&下位フォルダ名" & Date & "フォルダ用フォルダ名"

If objFSO.FolderExists(FolderSpec:=myFolderA) = False Then
objFSO.createfolder myFolderA
End If
If objFSO.FolderExists(FolderSpec:=myFolderB) = False Then
objFSO.createfolder myFolderB
End If
If objFSO.FolderExists(FolderSpec:=myFolderC) = False Then
objFSO.createfolder myFolderC
End If
If objFSO.FolderExists(FolderSpec:=myFolderL) = False Then
objFSO.createfolder myFolderL
End If
If objFSO.FolderExists(FolderSpec:=myFolderF) = False Then
objFSO.createfolder myFolderF
End If
'+----

目的フォルダへのパスを、そのフォルダ名にも含まれているID番号をキーワードにして検索したくて
その方法を色々探していたのですが
どこのサイトでも結局ファイルなどの一覧の取得方法になってしまっていました。

最終目的はシートに表示させたリンク先からのフォルダやファイルの新規フォルダへのコピーなのですが
せっかく作れるようになった新規フォルダに何もインポートできていない現状です。

よろしくご教授お願いします。

回答No.1

_Kyle

前回回答した者です。

今一つ状況を把握できていないので
補足要求のようになってしまいますが…。
-----------------------------
◆１
前回は
「あらかじめシート上に列挙されたパス一覧から前方一致検索して転記」
でしたが、
今回は
「直接ディレクトリを検索してフォルダのパスを取得し新規フォルダにコピー」
ということでしょうか？

今回、bシートのことは忘れてもOK？
-----------------------------
◆２
「ID番号を含む名前のついたフォルダ」のフォルダ名は
前回bシートのID列にあった
　B1234_ABC-TOUKYOUTONAKANOKU
　12345_DEF-TOUKYOUTOTOSHIMAKU
といったものと同様の形式でしょうか？

もしそうでないならば、差し支えの無い範囲でサンプルを。

　※単純に「"1234"を含む」で検索すると
　　B1234_ABC-TOUKYOUTONAKANOKU　だけでなく
　　12345_DEF-TOUKYOUTOTOSHIMAKU　や
　　912345_FED-TOUKYOUTONAKANOKU　もヒットしてしまいますから
　　ID番号の始まりと終わりの位置を判断する条件が必要です。
-----------------------------
◆３
「ID番号を含む名前のついたフォルダ」は
「日付毎に作成されたサブフォルダ」のすぐ下にあるのでしょうか
それともサブフォルダのさらにサブフォルダに…ということもあるのでしょうか？
-----------------------------
◆４
検索する際
・複数のフォルダがヒットする可能性は？
・複数ヒットした場合の処理は？
・フォルダではなくファイルがヒットする可能性は？
・ファイルがヒットした場合の処理は？
-----------------------------
◆５
>欲しいフォルダには下位フォルダとして、
>zipフォルダも含まれる(この中のデータが欲しい時もあり)
とのことですが
zipフォルダの内部を検索する必要があるのですか？
それとも単に、
「ID番号を含む名前のついたフォルダ」の内部に
zipフォルダがあるということですか？
========================================================
補足要求だけというのもなんなので
一応コードも書いてみましたが…。

動作の概要

　ID番号の桁数に応じて、カテゴリフォルダ1 または カテゴリフォルダ2 を選び
　その【２つ下の階層】（「日付毎に作成されたサブフォルダ」の直下）について
　前回bシートID列にあったのと同じ形式の名前のフォルダを検索し
　ヒットすれば、前回パスを書き込んだ列の【右隣の列】にパスを表示する
　複数ヒットした場合は上書きする

'-----↓ココカラ↓---------------------------------

　'【前略】

　'■宣言追加
　Dim ctFld As Folder
　Dim dtFld As Folder
　Dim tgFld As Folder

　'【中略】

　'■検索・コピペ
　For i = 1 To ipCnt

　　tpStr = ipAry(i) & "_*"
　　For j = idCnt To 1 Step -1
　　　If idAry(j) Like tpStr Then
　　　　lkRng.Cells(j, 1).Copy
　　　　rtRng.Cells(i, 1).PasteSpecial Paste:=xlPasteValues
　　　　Exit For
　　　End If
　　Next j

　　Select Case Len(ipAry(i))
　　　Case 4
　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ1へのパス」")
　　　　tpStr = "B" & tpStr
　　　Case 5
　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ1へのパス」")
　　　Case Is > 5
　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ2へのパス」")
　　End Select

　　For Each dtFld In ctFld.SubFolders
　　　For Each tgFld In dtFld.SubFolders
　　　　If tgFld.Name Like tpStr Then
　　　　　MsgBox tgFld.Path
　　　　　rtRng.Cells(i, 2).Value = tgFld.Path
　　　　End If
　　　Next tgFld
　　Next dtFld

　Next i

　'■終了
　Set FSO = Nothing
　If Not ckFlg Then dtBok.Close
　Application.Calculation = xlCalculationAutomatic

End Sub
'-----↑ココマデ↑---------------------------------

お礼

質問箱では何度も相談に乗っていただきありがとうございました
8月末に2度目の質問をした後急遽出張が決まってしまい
アカパスを会社に残したまま出てしまったので
ログインが出来ずアクションが起こせませんでした

ようやく出張が終わり今月から戻ってきて
また改めてVBAに着手できるようになりました

2度目の質問に対する回答、ありがとうございます
参考にさせてもらい、取り組んでいきます

もし寛大なお心で見守っていただけるのであれば
また相談に乗っていただけたらと思います

ありがとうございました＞＜

補足

ちなみにというか、不躾で申し訳ありませんが
お勧めのVBA教本のような参考書のような、そんなものありましたら
そちらも併せて教えて頂けたりすると嬉しいです＞＜

よろしくお願いします。