共有フォルダからのファイル名抽出(VBA)

以前、同様の質問をしたのですが、共有フォルダからファイル名+更新日の抽出する方法をご教示しただいたのですが、30分以上かかっても終わりませんでした・・・・(数が10000以上あるからかと思いますが。。。。)教えていただいたのに申し訳ありません。。。

改めて、更新日は不要にして、ある共有フォルダからファイル名をエクセルに出力する方法を教えていただけませんでしょうか？

B1セルには"ファイル名"というTITELが入っているので
B2セルより下(B2、B3、B4～)にファイル名を記載していくような構文です。
※Dir関数、もしくはそれより早い方法があれば、そちらでも構いません。

よろしくお願いします。

質問者からの補足コメント

• 

  回答ありがとうございます。
  共有フォルダなのですが、アクセスの権限はあるのですが、追加でファイルを保存できない管理設定になっているので、上記の方法ができません。自分のPC内にマクロエクセルファイルがある形でできないでしょうか？？

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/08/06 09:39

No.3 ベストアンサー 回答者： hallo-2007 回答日時： 2017/08/06 09:48

No1です。

先のファイルを自分のPCに保存
buf = Dir(ThisWorkbook.Path & "\*.xlsx")
の部分を
buf = Dir(”共有フォルダのパス” & "\*.xlsx")
に変更してみて下さい。

この回答へのお礼

上手くいきました。20秒程度の処理でしたので、充分使用できそうです！ありがとうございます

お礼日時：2017/08/09 19:58

No.5 回答者： x-1919 回答日時： 2017/08/08 14:21

以前の質問がどんなものか知らないのですが、ファイルパスじゃなくてファイル名が知りたいってことは、サブフォルダーまでは掘らないってことでしょうかね。

常套手段の FileSystemObject を使いましたが、「以前の回答では処理が遅かった」 というのはコレですかね。

Sub GetFileNames()
　　Dim wSheet As Worksheet
　　Set wSheet = ThisWorkbook.Worksheets(1)

　　Dim rowIndex As Long
　　rowIndex = 2

　　Dim fso As Object ' Scripting.FileSystemObject
　　Set fso = CreateObject("Scripting.FileSystemObject")

　　Dim root As Object ' Scripting.Folder
　　Set root = fso.GetFolder("E:\お仕事")

　　Dim f As Object ' Scripting.File
　　For Each f In root.Files
　　　　wSheet.Cells(rowIndex, 1).Value = f.Name
　　　　wSheet.Cells(rowIndex, 2).Value = f.DateLastModified
　　　　rowIndex = rowIndex + 1
　　Next
End Sub


既存の Excel ファイルのシートに直接出力するのではなく、CSV ファイルを生成するのでよろしければ PowerShell で一瞬なんですけどね。

Get-ChildItem -Force * | Where-Object { ! $_.PSIsContainer } | Select-Object Name, LastWriteTime | Export-Csv E:\tmp\Files.csv -Encoding Default

No.4 回答者： siffon9 回答日時： 2017/08/06 19:43

No.1です。

元の質問のNo.3さんのプログラムに改良を行ってみました。
　変更内容
　　テキストファイルの書き出さず、メモリ内で処理させる。
　　セルへの書き出し時にScreenUpdatingを禁止する

これで多少は改善されると期待しますが、元の質問のNo.3さんのプログラムで30分以上かかるということは、もっと他に考慮すべきポイントがあるかもしれません。

あと、ネットワーク上のフォルダを対象とするDir関数の使用は、以前挙動不審の動作でひどい目にあったことがあるので、個人的にはお勧めしません。


使用にあたっての前提
・A1セルに共有フォルダのパスが記載されていること
・記録先セルの事前クリアはしていません
・ファイル名、更新日時の記録開始セルの行と列をプログラム内で指定しておく
　（以下は、名前：B2セル、更新日時：C2セルを設定しています）

----------------------------------------------
Sub Pdflistup()
Const nameRow = 2 ' 名前記入開始行
Const nameCol = 2 ' 名前記入列（B列）
Const dateRow = 2 ' 更新日時開始行
Const dateCol = 3 ' 更新日時記入列（C列）

Dim fso As Object
Dim files As Object
Dim file As Object
Dim folderPath As String
Dim rng As Range

Dim names() As Variant
Dim mDate() As Variant
ReDim Preserve names(0)
ReDim Preserve mDate(0)

folderPath = Range("A1").Value: 'セルA1にフォルダーのパスがあるということなので。

Set fso = CreateObject("Scripting.FileSystemObject")
Set files = fso.GetFolder(folderPath).files

For Each file In files
names(UBound(names)) = CStr(file.Name)
mDate(UBound(mDate)) = CDate(file.DateLastModified)
ReDim Preserve names(UBound(names) + 1)
ReDim Preserve mDate(UBound(mDate) + 1)
Next
ReDim Preserve names(UBound(names) - 1)
ReDim Preserve mDate(UBound(mDate) - 1)
Set fso = Nothing
Set files = Nothing
Set file = Nothing

Application.ScreenUpdating = False
Dim i As Long
For i = 0 To UBound(names)
Cells(nameRow + i, nameCol).Value = names(i)
Cells(dateRow + i, dateCol).Value = mDate(i)
Next
Application.ScreenUpdating = True
MsgBox ("処理が完了しました。")
End Sub

No.2 回答者： hallo-2007 回答日時： 2017/08/06 08:50

一応参考までに

新規のファイルにボタンを配置
Sub ボタン1_Click()
buf = Dir(ThisWorkbook.Path & "\*.xlsx")
i = 2
Do While buf <> ""
Range("B" & i).Value = buf
i = i + 1
buf = Dir()
Loop
End Sub
を借りつけて閉じる。
検索したい共有フォルダに名前を付けて保存
その際には、マクロ有効ブック（拡張子 xlsm)で
ボタンをクリックすると、同じフォルダー内のエクセルファイル（拡張子 xlsx）の一覧が
B列に出来ます。

No.1 回答者： siffon9 回答日時： 2017/08/06 08:10

> 30分以上かかっても終わりませんでした

作業の頻度がよくわかりませんが、以下の方法の方が速くないですか？
VBAは使用しません。


１．対象の共有フォルダをネットワークドライブに割り当てて（例えばZドライブ）
２．下記一行のfilelist.batをメモ帳でexcelファイルのある場所に作成して、ダブルクリック

-----filelist.bat　　←共有フォルダのファイルリストを同じフォルダに作成
dir Z:\ /B /A-D > list.csv
-----

３．作成されたlist.csvをexcelで開いて、本来必要なシートにコピペする。


参考：
ネットワークドライブの割り当て　って何なのよ？
http://cryingsun-system.com/shorttime5/network.h …

※他にも情報はあると思います
　「ネットワークドライブ　割り当て」などで検索してください。