[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロでフォルダーの参照を行っているが、データフォルダの選択時にショートカットアイコンが表示されない』（toto）
初めて質問させていただきます。不慣れな点あればご容赦ください。
同じ様式のエクセルファイルが大量に格納されているフォルダを指定して、フォルダ内のファイルを集計・転記するというマクロを使用しています。
（マクロ全文を末尾に記載します）。
このマクロを使うと、フォルダーの参照（データフォルダを選択してください）というウィンドウが表示され、集計したいフォルダを選択する、選択するとフォルダ内のエクセルファイルを読み取り、転記されたデータが作成されるというものになっています。
このフォルダーの参照場面で表示されるデータファイルに、ショートカットアイコンが表示されないのですが、この点をなんとか修正したいと悩んでいます。
集計の対象である「エクセルファイルが格納されているフォルダ」は、職場の共有サーバーのかなり深い階層にあるので、
デスクトップにショートカットアイコンを作って、普段はそこからアクセスしているのですが、
このマクロだと共有サーバーの一番浅い階層から一つ一つ階層を潜っていって、お目当てのフォルダを指定する形になってしまい、非常に難儀しています。
大量にデータがあるため、別の場所にコピーするのも大変ですし、なんとか改善できないかと思っています。
初歩的な質問で恐縮ですが、ご助力いただけたら嬉しいです。
【以下使用しているマクロです】
Public Sub Main()
'*******************************************************************************
' データファイルから特定項目を抽出して一覧表を作成
'*******************************************************************************
Dim WBDAT As Workbook
Dim WS As Worksheet
Dim LIST As Worksheet
Dim strGuide As String
Dim FolderPath As String
Dim FileName As String
Dim lstRow As Long
Dim datRow As Long
Dim datEndRow As Long
Dim SavePath As String
strGuide = "データフォルダを選択してください。"
FolderPath = GetFolder(strGuide)
If FolderPath = "" Then Exit Sub
Application.ScreenUpdating = False
Set LIST = ThisWorkbook.Worksheets("集計シート")
lstRow = 3 '集計シートの開始行
'フォルダ内のデータファイルを順番に開く
FileName = Dir(FolderPath & "\*.xls?", vbNormal)
Do While FileName <> ""
Set WBDAT = Workbooks.Open(FolderPath & "\" & FileName)
Application.WindowState = xlMinimized
'処理中画面を表示
frmDoing.Show vbModeless
frmDoing.lblMsg.Caption = FileName & " を処理中です。"
DoEvents
For Each WS In WBDAT.Worksheets
'データを集計シートに転記
With WS
datEndRow = .Cells(Rows.Count, 2).End(xlUp).Row '労働者氏名
For datRow = 20 To datEndRow
'---------- ヘッダ --------------------------------------
LIST.Cells(lstRow, 1).Value = WBDAT.Name 'ファイル名
LIST.Cells(lstRow, 2).Value = .Range("C6").Value '受注者の商号又は名称
LIST.Cells(lstRow, 3).Value = .Range("I8").Value '下請業者の商号又は名称
LIST.Cells(lstRow, 4).Value = .Range("F11").Value '開始
LIST.Cells(lstRow, 5).Value = .Range("J11").Value '終了
'---------- 明 細 --------------------------------------
LIST.Cells(lstRow, 6).Value = .Range("A" & datRow).Value '番号
LIST.Cells(lstRow, 7).Value = .Range("B" & datRow).Value '労働者氏名
LIST.Cells(lstRow, 9).Value = .Range("D" & datRow).Value '従事職種
LIST.Cells(lstRow, 10).Value = .Range("E" & datRow).Value '支払形態
LIST.Cells(lstRow, 11).Value = .Range("F" & datRow).Value '労働日数
LIST.Cells(lstRow, 12).Value = .Range("G" & datRow).Value
LIST.Cells(lstRow, 13).Value = .Range("H" & datRow).Value
LIST.Cells(lstRow, 14).Value = .Range("I" & datRow).Value
LIST.Cells(lstRow, 15).Value = .Range("J" & datRow).Value
LIST.Cells(lstRow, 16).Value = .Range("K" & datRow).Value
LIST.Cells(lstRow, 17).Value = .Range("L" & datRow).Value
LIST.Cells(lstRow, 18).Value = .Range("M" & datRow).Value
LIST.Cells(lstRow, 19).Value = .Range("N" & datRow).Value
LIST.Cells(lstRow, 20).Value = .Range("O" & datRow).Value
LIST.Cells(lstRow, 21).Value = .Range("P" & datRow).Value
LIST.Cells(lstRow, 22).Value = .Range("Q" & datRow).Value
lstRow = lstRow + 1
Next datRow
End With
Next WS
WBDAT.Close SaveChanges:=False
FileName = Dir()
Loop
'処理中画面を閉じる
Unload frmDoing
'シートを名前を付けて保存
SavePath = ConvOneDrivePath(ThisWorkbook.Path) & "\" & "集計結果_" & Format(Date, "yyyymmdd") & ".xlsx"
If Dir(SavePath) <> "" Then
Kill SavePath
End If
LIST.Copy
ActiveWorkbook.SaveAs FileName:=SavePath, FileFormat:=xlWorkbookDefault
ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox "集計シートを作成しました。", vbInformation, "データ抽出"
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub
Public Function GetFolder(strGuide As String) As String
'*******************************************************************************
' 選択したフォルダのパスを返す
'*******************************************************************************
Dim WSH As Object
Dim ObjPath As Object
Set WSH = CreateObject("Shell.Application")
Set ObjPath = WSH.BrowseForFolder(0, strGuide, 0)
If Not ObjPath Is Nothing Then
On Error GoTo ERR_JUMP
GetFolder = ObjPath.items.Item.Path
On Error GoTo 0
End If
Exit Function
ERR_JUMP:
Err.Clear
GetFolder = CreateObject("Wscript.shell").specialfolders("Desktop")
End Function
Public Function ConvOneDrivePath(ByVal myPath) As String
'*******************************************************************************
' Web版(OneDrive)のフルパスをローカルパスに変換
'*******************************************************************************
Dim buf As Variant
Dim FirstHalfPath As String
Dim i As Long
If Left(myPath, 5) = "https" Then
FirstHalfPath = Environ("UserProfile") & "\OneDrive"
'ThisWorkbook.Pathにおいて、https://d.docs.live.net/までを削除
buf = Replace(myPath, "https://d.docs.live.net/", "")
'最初の/まではOneDriveのパスの続きなので、その次のパスから拾う
buf = Split(buf, "/")
myPath = FirstHalfPath
For i = 1 To UBound(buf)
myPath = myPath & "\" & buf(i)
Next i
ConvOneDrivePath = myPath
Else
ConvOneDrivePath = myPath
End If
End Function
＜ 使用 Excel：Excel2019、使用 OS：unknown ＞
フォルダ指定の操作において、適切な初期値を設定しておきたい、 というお話ですね。
(1) http://officetanaka.net/excel/vba/tips/tips39.htm にあるように Shell.BrowseForFolderの最後の引数で、そうしたフォルダの初期値を指定できます。 ネットワーク上のパスが指定できるか未確認ですが、トライしてみては？
(2)別法
最初のサンプルの手法を使うと、その時のカレントなフォルダが初期値になります。
Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
End If
End With
End Sub
そこで、ネットワーク上のフォルダをカレントフォルダにするには、
http://officetanaka.net/other/extra/tips15.htm
にあるSetCurrentDirectoryを使うと良いでしょう。
（なお、現在のカレントフォルダを変数に退避させておいて、 フォルダ指定が済んだら、復旧させる処理も加えるとよいでしょう。） （γ） 2022/05/26(木) 06:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.