VBA 複数のホルダー・Sheet名を変数に

質問

VBAの初心者です。
サーバ内の各ホルダーに入っているファイル情報をSheetに書き出しさらにそのファイル名にハイパーリンクをつけてファイルを参照するマクロをWebから例を参照させて頂き作成しました。
マクロを作成した目的は、頻繁に更新されるネットワーク越しのファイルを
ユーザ単位で指定したホルダー分参照出来るようにしたい為です。
そして、VBAを意識せず安易に誰でもこのマクロを実行出来るようにする事です。

とりあえず、下記マクロ文で、M:\01_仕事\10_仕様書ホルダー内のファイル情報を
　Sheet名＝仕様書へ書き込む事は出来て、ハイパーリンクも貼れてファイル内の参照は出来ています。
作成したSheetを画像添付しました。
しかし、下記点が旨く出来ません、ご教示頂けたらと思います。
・このマクロ内で複数、参照したいファイルのホルダー名と書き出すSheet名を、変数や配列などに
　記述して一挙に作成したい。
・下記マクロ内のPrivate Sub FileDisp(strPath, i)ではWorksheetsの所で変数名が使えない為、
　Worksheets("仕様書").Cells(i, 2)などと、Sheetの名前をいちいち記述しました。
　複数のホルダーに対応させるにはどうしたら良いか？
---------以下はマクロ文　-------------------------------------------------------------------------------------
Private Sub test7()
'Private Sub Auto_Open()
Dim a As String
Dim b As String
a = "仕様書"
b = "M:\01_仕事\10_仕様書"
Call SHEETNAME(a)
Call FORDERR(a, b)
End Sub

Sub SHEETNAME(a)
'SheetAddDelの使用例
SheetAddDel (a)
End Sub

Sub SheetAddDel(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetを削除する。
'それから、新しいSheetを挿入する
Dim sh As Object
For Each sh In Worksheets
If sh.Name = shname Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh
Sheets.Add.Name = shname
End Sub

Private Sub FORDERR(a, b)
strPath = b
Range("c1").Value = strPath
Worksheets("仕様書").Cells(3, 2) = " "
Range("A3", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Range("A3").Select
i = 3
FileDisp strPath, i
End Sub

Private Sub FileDisp(strPath, i)
Dim WSname As String
Dim WSvalue As String
'Application.ScreenUpdating = False '画面を固定する事により高速化しま
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFld = objFs.GetFolder(strPath)
Worksheets("仕様書").Cells(i, 2) = objFld.Path 'sak
With Worksheets("仕様書").Cells(i, 2).Font 'sak
.Bold = True 'sak
End With 'sak

With Worksheets("仕様書").Cells(i, 2).Interior 'sak
.ColorIndex = 6 'sak
.Pattern = xlSolid 'sak
End With 'sak

i = i + 1 ' サブフォルダ名を入れるsak
For Each objFl In objFld.Files
Worksheets("仕様書").Cells(i, 2).Select
WSname = objFl.ParentFolder.Path & "\" & objFl.Name 'hyperlink用sak
WSvalue = objFl.Name
'ヘルプの「Addメソッド」から「Hyperlinks オブジェクトの Add メソッド」を参照
Worksheets("仕様書").Hyperlinks.Add anchor:=Cells(i, 2), _
Address:=WSname, ScreenTip:=WSname, TextToDisplay:=WSvalue

With Worksheets("仕様書")

.Cells(i, 2).Font.Size = "11"
.Cells(i, 3) = objFl.ParentFolder.Path & "\" & objFl.Name ' フルパスに変更sak
.Cells(i, 4) = Int(objFl.Size / 1024)
.Cells(i, 5) = objFl.Type
.Cells(i, 6) = objFl.DateCreated
.Cells(i, 7) = objFl.DateLastAccessed
.Cells(i, 8) = objFl.DateLastModified
End With
i = i + 1
Next
For Each objSub In objFld.SubFolders
FileDisp objSub.Path, i
Next
End Sub
------------------------------------------------------------------------------------------------------------------------------

回答No.7

BarcodeMaster · ベストアンサー

ANo.1です。

とりあえず、やりたいことができたということで、良かったです。
さて、新たにご質問されるのであれば、一旦、この質問は閉じてくださいね。
あらためて、質問したらよろしいかと思います。

ただ、新たな質問の内容は、既にあなたが身に着けていなければならない内容です。
今回のコードを、1行1行見なおして、なにをやっているのか理解してください。

また、「Excel VBA」でGoogleなどで検索すれば、VBAのプログラミング入門サイトは
かなりの数、出てきます。まずはそちらで勉強されることをお奨めします。
そこで大半の答えは得られるでしょう。

お礼

BarcodeMasterさん、
厳しく、優しい沢山のアドバイスありがとうございました。
ここまで完成出来たのは、これらのアドバイスのお蔭です。
これからも、ネットで勉強しながらVBAの勉強を続けていけたらと思います。

回答No.6

BarcodeMaster

ANo.1です。

あ、すみません。

Folderって、FileSystemObjectに含まれるオブジェクトみたいですね。

参照設定されていないのでしょうね。
http://www.relief.jp/itnote/archives/fso-vba-references.php

他にも、突っ込みどころが、いろいろありすぎます。
もう一度、コードを見なおしてください。
上記の設定しても、動きません。^^;

補足

BarcodeMasterさんご教示ありがとうございました。

ご指摘通りで、
(1)参照設定→Microsoft Scripting Runtime］→チェックボックスOn
　をした所「ユーザー定義型は定義されていません。」エラーは出なくなりました。

(2)下記はスペースが変なところに入ってたり、
　入れるべきところにはいってなかったり
　()で囲んてなかった
　渡す引数もstrPathとstrSheetNameだけでよいのに、i, jを
　つけていたので、↓下のように修正しOKになりました。
Callファイル一覧取得 strPath(intCnt), i, j, strSheetName(intCnt)
　　　　　　　　　　　　　↓
Call ファイル一覧取得(strPath(intCnt), strSheetName(intCnt))

参照ホルダーを削除、追加する時は
strPathとstrSheetNameの配列だけ削除、追加をするだけなので、
便利でファイル参照も見やすくなりました。

更にやりたい事が有ります。
参照するフォルダーパスとファイル一覧表示用シート名の削除、追加を
VBAのコード内でやるのではなくExcelのあるシートに書き込んで置いて、
そこを参照するコードにしたいと思っています。
今の自分の力では、どのようにしたら良いのか分かりません。
ご教示頂けたら大変助かります。
よろしくお願いします。

回答No.5

BarcodeMaster

ANo.1です。

エラーが発生する箇所を特定してください。
メニュー-[デバッグ]-[VBAProjectのコンパイル]
をやれば、その行に飛んで、エラーメッセージが表示されます。

こちらでやってみたら、
Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long, ByRef j As Long)
ここに飛びます。
「ユーザー定義型は定義されていません。」ですね。
その中で不正な型を探しましょう。Folderでしょうね。

じゃあ、どういうことか・・・
Folder型をコピペし忘れているんでしょう。

補足

『どういうことか』『Folder型をコピペし忘れている』ですが、アドバイスを頂いてからずーとネットで調べたり、コードをいじったりして見ましたが解決出来ませんでした。
ご教示頂けると大変助かります。

回答No.4

BarcodeMaster

ANo1です。
配列に値をセットして、ループさせるだけです。
何が理解できていなかったのか、確認してください。

Dim strPath(2) As String
Dim strSheetName(2) As String
Dim intCnt As Integer

strPath(0) = "M:\a.xls"
strSheetName(0) = "仕様書a"
strPath(1) = "M:\b.xls"
strSheetName(1) = "仕様書b"
strPath(2) = "M:\c.xls"
strSheetName(2) = "仕様書c"

For intCnt = 0 To 2
Call FORDERR(strPath(intCnt), i, strSheetName(intCnt))
Next intCnt

補足

BarcodeMasterさんご教示ありがとうございました。
ほんの少々ですが、ご教授のお蔭でVBAの基本が分かるようになりました。
ご指摘頂いた通りに実施し、複数のホルダー参照をする事が出来ました。
VBAの基本の勉強不足と実感しております。
ネットで調べていて、今のコードより、より自分がしたいコードを見つけました。
自分なりに挑戦して見ます、どうしても解決出来ない時は、どうぞお力(アドバイス)をよろしくお願い致します。

回答No.3

BarcodeMaster

ANo1です。

すみません、VBAでしたね。

VBAの情報も同じことです。

お礼

補足コメント欄に記載したコンパイルエラー：「引数は省略できません」のエラーの
原因が解りました。
FileDispの所で引数が足りてなかった事にやっと気がつきました。
しかしまだ、
Private Sub test7()の
strSheetNameやstrPathに複数の値を代入し、ループ式にして、
下記Subを値を代入した分起動させるやり方がまだつかめていません。
コードを下記へ記載させて頂きました。
Private Sub test7()

Dim strSheetName As String
Dim strPath As String

strSheetName = "仕様書"
strPath = "M:\01_仕事\10_仕様書"

Call FORDERR(strPath, i, strSheetName)

End Sub

Sub SHEETNAME(strSheetName)

'SheetAddDelの使用例
SheetAddDel (strSheetName)
End Sub

Sub SheetAddDel(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetを削除する。
'それから、新しいSheetを挿入する

Dim sh As Object

For Each sh In Worksheets
If sh.Name = shname Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh

Sheets.Add.Name = shname
End Sub

Private Sub FORDERR(ByVal strPath As String, ByVal i As Integer, ByVal strSheetName As String)

Range("c1").Value = strPath

Worksheets(strSheetName).Cells(3, 2) = " "

Range("A3", ActiveCell.SpecialCells(xlLastCell)).ClearContents

Range("A3").Select
i = 3

FileDisp strPath, i, strSheetName

End Sub

Private Sub FileDisp(ByVal strPath As String, ByVal i As Integer, ByVal strSheetName As String)

'Private Sub FileDisp(strPath As String, i As Integer, strSheetName As String)

Dim WSname As String
Dim WSvalue As String

'Application.ScreenUpdating = False '画面を固定する事により高速化します

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFld = objFs.GetFolder(strPath)

Worksheets(strSheetName).Cells(i, 2) = objFld.Path

With Worksheets(strSheetName).Cells(i, 2).Font

.Bold = True
End With

With Worksheets(strSheetName).Cells(i, 2).Interior

.ColorIndex = 6
.Pattern = xlSolid
End With

i = i + 1 ' サブフォルダ名を入れるsak

For Each objFl In objFld.Files

Worksheets(strSheetName).Cells(i, 2).Select

WSname = objFl.ParentFolder.Path & "\" & objFl.Name 'hyperlink用sak
WSvalue = objFl.Name

'ヘルプの「Addメソッド」から「Hyperlinks オブジェクトの Add メソッド」を参照
Worksheets(strSheetName).Hyperlinks.Add anchor:=Cells(i, 2), _
Address:=WSname, ScreenTip:=WSname, TextToDisplay:=WSvalue

With Worksheets(strSheetName)

.Cells(i, 2).Font.Size = "11"
.Cells(i, 3) = objFl.ParentFolder.Path & "\" & objFl.Name ' フルパスに変更sak
.Cells(i, 4) = Int(objFl.Size / 1024)
.Cells(i, 5) = objFl.Type
.Cells(i, 6) = objFl.DateCreated
.Cells(i, 7) = objFl.DateLastAccessed
.Cells(i, 8) = objFl.DateLastModified

End With

i = i + 1
Next
For Each objSub In objFld.SubFolders
FileDisp objSub.Path, i, strSheetName

Next
End Sub

補足

VBAの基本について、ネットでいろいろ調べながら、コードを修正してみましたが、
下記コードの所でコンパイルエラー：「引数は省略できません」のエラーが出力されます。混乱するばかりで、エラーを解消する事が出来ませんでした。
Private Sub test7()
Dim a As String
Dim b As String
a = "仕様書"
b = "M:\01_仕事\10_仕様書"
Call SHEETNAME(a)
Call FORDERR(a, b)　　<--ここが原因らしい
End Sub
勉強が足りてないのは、重々わかっておりますが、もうどうにも進まなくなったので、アドバイスをお願いしたいと思います。下記にコードを記載致します。
Private Sub test7()
Dim a As String
Dim b As String

a = "仕様書"
b = "M:\01_仕事\10_仕様書"

Call SHEETNAME(a)
Call FORDERR(a, b)

End Sub

Sub SHEETNAME(a)
'SheetAddDelの使用例
SheetAddDel (a)
End Sub

Sub SheetAddDel(shname As String)
'現在のWorkbookに同名のSheetがないか確認する。
'あれば、そのSheetを削除する。
'それから、新しいSheetを挿入する

Dim sh As Object

For Each sh In Worksheets
If sh.Name = shname Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh

Sheets.Add.Name = shname
End Sub

Private Sub FORDERR(a, b, ByVal strSheetName As String)
strSheetName = a
strPath = b

Range("c1").Value = strPath

Worksheets(strSheetName).Cells(3, 2) = " "

Range("A3", ActiveCell.SpecialCells(xlLastCell)).ClearContents

Range("A3").Select
i = 3

FileDisp strPath, i

End Sub

Private Sub FileDisp(ByVal strPath As String, ByVal i As Integer, ByVal strSheetName As String)

Dim WSname As String
Dim WSvalue As String

'Application.ScreenUpdating = False '画面を固定する事により高速化します

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFld = objFs.GetFolder(strPath)

Worksheets(strSheetName).Cells(i, 2) = objFld.Path

With Worksheets(strSheetName).Cells(i, 2).Font

.Bold = True
End With

With Worksheets(strSheetName).Cells(i, 2).Interior

.ColorIndex = 6
.Pattern = xlSolid
End With

i = i + 1 ' サブフォルダ名を入れるsak

For Each objFl In objFld.Files

Worksheets(strSheetName).Cells(i, 2).Select

WSname = objFl.ParentFolder.Path & "\" & objFl.Name 'hyperlink用sak
WSvalue = objFl.Name

'ヘルプの「Addメソッド」から「Hyperlinks オブジェクトの Add メソッド」を参照
Worksheets(strSheetName).Hyperlinks.Add anchor:=Cells(i, 2), _
Address:=WSname, ScreenTip:=WSname, TextToDisplay:=WSvalue

With Worksheets(strSheetName)
.Cells(i, 2).Font.Size = "11"
.Cells(i, 3) = objFl.ParentFolder.Path & "\" & objFl.Name ' フルパスに変更sak
.Cells(i, 4) = Int(objFl.Size / 1024)
.Cells(i, 5) = objFl.Type
.Cells(i, 6) = objFl.DateCreated
.Cells(i, 7) = objFl.DateLastAccessed
.Cells(i, 8) = objFl.DateLastModified
End With
i = i + 1
Next
For Each objSub In objFld.SubFolders
FileDisp objSub.Path, i, a

Next
End Sub

回答No.2

BarcodeMaster

ANo1です。

であれば、

「VB.NET 配列」
「VB.NET 関数の作り方」

などで検索すれば、知りたい情報は出てくるのではないですか？

そもそも、基本の基本を理解していないようなので、VB.NETの参考書を2・3冊読まれてはいかがですか？
それができない理由でもあるんでしょうか？
買えないならば図書館にでもありますよ。

今は、ネットに情報があふれてるので、ネットで調べればたいていのことは解決しますが、
基本はやはり専門書で勉強するべきです。
これからあなたがプログラマーを目指すのであれば、避けて通れないことです。
もし、そうでないならば、業者に対価を払って依頼すべきです。

補足

2015/10/5の補足コメントで、より自分がしたいコードを見つけましたと書きましたが、表示書式を見やすいく整形させるコードです。
そのコードを自分のコードに修正追加して見ましたが、
Callファイル一覧取得 (strPath(intCnt), strSheetName(intCnt))でエラーになっているようで、コードを実行させると『ユーザ型は定義されていません』のエラーになります。どの部分が誤っているのか分かりませんでした。
どうぞアドバイスをよろしくお願いします。下記にコードを記載させて頂きました。
申し訳ありません、コード全文記載できませんでした。
Option Explicit
Private Sub test8()
'Private Sub Auto_Open()
Public Const cnsRow As Long = 4 '開始行
Public Const cnsCol As Long = 2 '開始列
Public ColMax As Long '最終列
Dim strPath(2) As String
Dim strSheetName(2) As String
Dim intCnt As Integer
strPath(0) = "M:\01_仕事\10_仕様書\"
strSheetName(0) = "仕様書"
strPath(1) = "M:\01_仕事\05_マニュアル管理\"
strSheetName(1) = "マニュアル管理"
strPath(2) = "M:\01_仕事\07_勤怠\"
strSheetName(2) = "勤怠"
For intCnt = 0 To 2 '0行から始めて2行まで（1upで）
Call SHEETNAME(strSheetName(intCnt))
Callファイル一覧取得 (strPath(intCnt), strSheetName(intCnt))
Next intCnt 'intCntの繰り返し
End Sub

Sub SHEETNAME(strSheetName)
SheetAddDel (strSheetName)
End Sub

Sub SheetAddDel(shname As String)
Dim sh As Object
For Each sh In Worksheets
If sh.Name = shname Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh
Sheets.Add.Name = shname
End Sub

Sub ファイル一覧取得()
Dim strPath As String
Dim strSheetName As String
Dim objFSO As FileSystemObject
Dim strDir As String
Dim i As Long, j As Long
Worksheets (strSheetName)
Range("b4").Value = strPath
strDir = Cells(cnsRow, cnsCol)
Set objFSO = New FileSystemObject
Application.ScreenUpdating = False
Range(Rows(cnsRow), Rows(Cells.SpecialCells(xlCellTypeLastCell).Row)).Clear
Cells(cnsRow, cnsCol) = strDir
i = cnsRow + 1
j = cnsCol
ColMax = cnsCol
Call GetDirFiles(objFSO.GetFolder(strDir), i, j)
Set objFSO = Nothing
Range(Columns(cnsCol), Columns(Columns.Count)).ColumnWidth = 3
Range(Columns(ColMax), Columns(ColMax + 2)).EntireColumn.AutoFit
Call SetLine2(Range(Cells(cnsRow, ColMax + 1), Cells(i - 1, ColMax + 2)))
Call SetLine3(Range(Cells(cnsRow, cnsCol), Cells(cnsRow, ColMax + 2)))
Call SetLine3(Range(Cells(cnsRow + 1, cnsCol), Cells(i - 1, ColMax + 2)))
Cells(cnsRow, ColMax).Font.Bold = True
With Cells(cnsRow, ColMax + 1)
.Value = "サイズ"
.HorizontalAlignment = xlRight
End With
With Cells(cnsRow, ColMax + 2)
.Value = "更新日時"
.HorizontalAlignment = xlRight
End With
Cells(cnsRow, cnsCol).Select
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long, ByRef j As Long)
Dim objFolderSub As Folder
Dim objFile As File
Dim strSplit() As String
Application.StatusBar = objFolder.Path
If j > ColMax Then
Columns(j).Insert Shift:=xlToRight
ColMax = j
End If
For Each objFolderSub In objFolder.SubFolders
Cells(i, j) = objFolderSub.Name
Call SetLine1(i, j)
i = i + 1
Call GetDirFiles(objFolderSub, i, j + 1)
Next
For Each objFile In objFolder.Files
With objFile
Cells(i, j) = .Name
strSplit = Split(objFile.Path, ".")
If UBound(strSplit) > 0 Then
Select Case LCase(strSplit(UBound(strSplit)))
Case "xls", "xlsx", "doc", "docx", "pdf"
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(i, j), _
Address:=.Path, _
TextToDisplay:=.Name
End Select
End If
Cells(i, ColMax + 1) = WorksheetFunction.RoundUp(.Size / 1024, 0)
Cells(i, ColMax + 1).NumberFormatLocal = "#,##0 ""KB"""
Cells(i, ColMax + 2) = .DateLastModified

回答No.1

BarcodeMaster

>・このマクロ内で複数、参照したいファイルのホルダー名と書き出すSheet名を、変数や配列などに
>　記述して一挙に作成したい。

何がうまくいかないんでしょうか？
配列がわからないということですか？

>・下記マクロ内のPrivate Sub FileDisp(strPath, i)ではWorksheetsの所で変数名が使えない為、
> 　Worksheets("仕様書").Cells(i, 2)などと、Sheetの名前をいちいち記述しました。

Private Sub FileDisp(ByVal strPath As String,ByVal i As Integer,ByVal strSheetName As String)
・・・
Worksheets(strSheetName).Cells(i, 2)・・・
・・・
End Sub

というようにして、

FileDisp strPath, i, a

とコールすればできますよね？

書かれているプログラムのレベルと、あなたの質問のレベルが合っていません。
多分、コピペして動いたからOKと思ってるんじゃないですか？
コピペするのは、構いませんが、一つ一つの記述が何をやっているのか、ちゃんと理解していかないとプログラミング力は向上しませんよ。

補足

>書かれているプログラムのレベルと、あなたの質問のレベルが合っていません
　おっしゃる通りです、説明もめちゃくちゃですみません。
　したい事を書きます。
　参照したいファイルが入っているホルダー名と表示させる為のSheet名を配列に格納し、順番にこれらを実行させたい。
配列とArray、間違えているかもしれませんが、
Array1には参照したいファイルが入っているホルダー名を入れる。
Array2には表示させる為のSheet名をいれる。
Array１(　"24年度仕様書", "25年度仕様書", "26年度仕様書",　"27年度仕様書”)
Array2 (　"24年度仕様書参照", "24年度仕様書参照", "24年度仕様書参照", "24年度仕様書参照" )

それから、ご教示頂いた、下記プロシージャですが、具体的に自分のコードに
どのように反映させたら良いか解りません。すみません、猿にも分かるように説明して頂けると大変うれしいです。

＜Private Sub FileDisp(ByVal strPath As String,ByVal i As Integer,ByVal strSheetName As String)
・・・
Worksheets(strSheetName).Cells(i, 2)・・・
・・・
End Sub

以上　よろしくお願いします。