初心者の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番号をキーワードにして検索したくて
その方法を色々探していたのですが
どこのサイトでも結局ファイルなどの一覧の取得方法になってしまっていました。
最終目的はシートに表示させたリンク先からのフォルダやファイルの新規フォルダへのコピーなのですが
せっかく作れるようになった新規フォルダに何もインポートできていない現状です。
よろしくご教授お願いします。
