Excel VBA 質問スレ Part83 (612ﾚｽ)
上下前次1-新
抽出解除 ﾚｽ栞
149(2): デフォルトの名無しさん [] 2025/06/19(木) 18:29:25.72 ID:CkE44pQz(1) AAS
>>147
147(1): デフォルトの名無しさん [] 2025/06/19(木) 13:03:13.43 ID:DFOz6nBR(1/2) AAS
>>145
共通関数だってpublicだろうし、public変数を共通で使っても何も問題ない
使い方間違えば（=バグ）エラー起こすのは当たり前
もちろんpublicにする必要のないものは対処必要
パブリック変数をコンストのノリで使用する事と、関数（public関数）を使う事は違う
283: デフォルトの名無しさん [] 2025/06/27(金) 21:38:05.72 ID:1l5DAmC+(1) AAS
>>280
280(2): デフォルトの名無しさん [sage] 2025/06/27(金) 18:10:56.90 ID:hBRiuDb/(1) AAS
検索したら出てくるレベルの質問なら確実に答えてくれるが、どこにも例題がないやつは嘘しか言わない
結局はGoogle代行でしかない
おい言ってみろよ
それっぽいこと適当に言ってると低年収バレバレで失禁するぞ？
311(1): デフォルトの名無しさん [] 2025/06/30(月) 20:48:43.72 ID:XO4EHMtF(1) AAS
>>310
310(1): デフォルトの名無しさん [] 2025/06/30(月) 20:01:12.87 ID:9Mnf4Vk7(1/2) AAS
>>309
センスも作り込みスキルも無さそうでしょうか？
ごめん、そんなことはないけど
印刷のVBA化に無理に固執するもんじゃない
マジで
昔経験したからわかる
423: デフォルトの名無しさん [sage] 2025/07/17(木) 23:26:46.72 ID:DMF1qliv(1) AAS
Chatさん。未検証
再帰使わずキュー処理
Sub FastSearchMinimal()
Dim fso As Object, q As Collection, f As Object, i As Object
Dim r As Long: r = 2
Dim k As String: k = "sample"
Set fso = CreateObject("Scripting.FileSystemObject")
Set q = New Collection: q.Add fso.GetFolder("C:\TestFolder")
With Sheets(1): .Cells.Clear: .Range("A1:C1").Value = Array("種類", "名前", "パス"): End With

Do While q.Count > 0
Set f = q(1): q.Remove 1
For Each i In f.SubFolders: q.Add i: If InStr(1, i.Name, k, vbTextCompare) > 0 Then WriteRow r, "フォルダ", i.Name, i.Path
Next
For Each i In f.Files: If InStr(1, i.Name, k, vbTextCompare) > 0 Then WriteRow r, "ファイル", i.Name, i.Path
Next
Loop
MsgBox "完了"
End Sub

Sub WriteRow(ByRef r As Long, t As String, n As String, p As String)
With Sheets(1): .Cells(r, 1).Resize(1, 3).Value = Array(t, n, p): End With: r = r + 1
End Sub
426: デフォルトの名無しさん [sage] 2025/07/18(金) 08:22:30.72 ID:avd6O0J8(1) AAS
>>417
417(3): デフォルトの名無しさん [sage] 2025/07/17(木) 08:47:01.58 ID:sGHKyXGW(1) AAS
>>410
Dirでワイルドカードが使えるので、こんな感じに仕上げてみた
※ヒットするパスの例 → C:\Documents\A001\B000X1\Excel\20250717\FileABC001.xlsx

HomePath = "C:\Documents"
SearchPath = "A???\B*\Excel\2025????\File*.xlsx"

ResultPath = HomePath
SearchPathList = Split(SearchPath, "\")
For I = 0 To UBound(SearchPathList)
　If Dir(ResultPath) <> "" Then
　　ResultPath = "ファイルの下は何もないよ！"
　　Exit For
　End If
　FolderName = Dir(ResultPath & "\" & SearchPathList(I), vbDirectory)
　If FolderName = "" Then
　　ResultPath = "そんなパスはないよ！"
　　Exit For
　End If
　ResultPath = ResultPath & "\" & FolderName
Next
MsgBox "これかな？" & vbCrLf & ResultPath
はちょっと手抜きしてたので、ちゃんと作り直した｡
Sub 使い方()
　Set Result = New Collection
　DirMulti "C:\Documents", "A???\B*\Excel\2025????\File*.xlsx", Result, vbNormal
　(以下略)
End Sub

Sub DirMulti(HomePath, SearchPath, ResultCollection, Optional Attributes As VbFileAttribute = vbNormal)
　Pos = InStr(SearchPath & "\", "\")
　Search = Left(SearchPath, Pos - 1)
　NextSearch = Mid(SearchPath, Pos + 1)

　Set SearchResult = New Collection
　Res = Dir(HomePath & "\" & Search, vbDirectory Or Attributes)
　Do While Res <> ""
　　If Res <> "." And Res <> ".." Then SearchResult.Add Res
　　Res = Dir()
　Loop

　If NextSearch = "" Then
　　For Each Res In SearchResult
　　　ResultCollection.Add HomePath & "\" & Res
　　Next
　Else
　　For Each Res In SearchResult
　　　If (GetAttr(HomePath & "\" & Res) And vbDirectory) <> 0 Then
　　　　DirMulti HomePath & "\" & Res, NextSearch, ResultCollection, Attributes
　　　End If
　　Next
　End If
End Sub
585: デフォルトの名無しさん [] 2025/08/03(日) 10:49:30.72 ID:46rmLnF/(1) AAS
４〜５年も出来ない出来ないって愚痴ってる時間で手動で取り込んだら終わってたのにな
上下前次1-新書関写板覧索設栞歴
ｽﾚ情報 赤ﾚｽ抽出 画像ﾚｽ抽出 歴の未読ｽﾚ AAｻﾑﾈｲﾙ
ぬこの手 ぬこTOP 0.029s