VBA セルに設定したフォルダパスでマクロを正常に動作させる方法

Question

今現在、作成中のマクロで、以下のようにしてフォルダのパスを指定して、その後の処理を実装しています。

Const strDefaultPath    As String = "パスの指定" 

それを、Excelのセル上に記載したパスをstrDefaultPathの値に代入し、マクロのパスをいじらなくても、Excel上にフォルダのパスを指定すれば正常に動作するようにしたいのですが、どのようにソースを修正すれば良いでしょうか。

今回の場合、フォルダのパスを指定するのはD1セルとします。

以下のように書いて見てもうまくできませんでした

    Dim strDefaultPath As Variant
    strDefaultPath = Range("D1").Value

パスを指定したい場所の参考画像（この画像のD1:F1の位置でパスを指定）

申し訳ありませんが、宜しくお願いします。

Comments

[otn]

質問ポイントは何でしょう？
VBAを書いている人がセルの値の参照方法が分からないと言うことはないと思うのですが？

[icecleam]

それがわからなくて困っています。。
Dim strDefaultPath As Variant
strDefaultPath = Range("D1").Value

のようにして見たのですが、あたいが取れませんでした

[meg_]

> 以下のように書いて見てもうまくできませんでした
具体的にはどういうことでしょうか？

[icecleam]

Dim strDefaultPath As Variant
strDefaultPath = Range("D1").Value

上記のように、記載して実行を試みましたが

Const strDefaultPath As String = "パスの指定"

と記載した時と同じ動作はせずに何も処理されなかった

という意味です

[ttyp03]

コードはどこに置いているのか。標準モジュールか対象とするシートか。
strDefaultPath の値は確認したのか。
情報を追記してください。

Answer 1

wsTo.cslls(1,4).Value

パスの最後は\マーク必要だから．．．
あとはセル結合の場合先頭のセルじゃないと値取れない。
セル接合が"D1:D4"なら取得できるが"B1:D3"とかなら取れない

追記
多分私しかこれ答えられないよ？
多分構文エラー起きているでしょう
あとパス("C1"の値)は必ず""で終わる事！
○"c:\test"
×"c:\test"

23行目これを消す
' Const strDefaultPath    As String = "パスを指定する"
新たに
' Dim varDefaultPath    As Variant

変数名の変更

33行目
    'strFromXMLFileName = Dir(strDefaultPath & "*.xls") 元はこっち
    strFromXMLFileName = Dir(varDefaultPath & "*.xls")

変数名の変更

39行目
        'Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName) 元はこっち
        Set wbFrom = Workbooks.Open(varDefaultPath & strFromXMLFileName)

Comments

[icecleam]

以下のように書きましたが、「オブジェクト変数またはWithブロック変数が設定されていません」というエラーメッセージが出てしまいました。

・ご回答者様の.csllsというのは誤字かと思い省略しました

Dim strDefaultPath As Variant
strDefaultPath = wsTo.Cells(1, 4).Value

[kuma_kuma_]

確かに誤字でしたので修正しました。

[icecleam]

編集後の回答を参考に以下のように修正しましたが
やはり同じエラーが出てしまいます。。

'Const strDefaultPath As String = "" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
Dim varDefaultPath As Variant
varDefaultPath = wsTo.Cells(1, 4).Value
〜〜〜
' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
'strFromXMLFileName = Dir(strDefaultPath & "*.xls")
strFromXMLFileName = Dir(varDefaultPath & "*.xls")
〜〜〜〜
' 見つかったExcelブックを開く
'Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
Set wbFrom = Workbooks.Open(varDefaultPath & strFromXMLFileName)

[kuma_kuma_]

3つ目の変更行に誤りがありました
×33行目
○39行目

33 行目でブレークポイントで止める
varDefaultPath の中身を確認
入っているなら
39 行目まで進むので
39 行目でブレークポイントで止める
varDefaultPath と
strFromXMLFileNameの中身を確認
これで値が全て正常ならまた連絡下さい。

とその前に
>varDefaultPath = wsTo.Cells(1, 4).Value
これ書くの

この行の
> ' コピー先の設定
> Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
後だからね！

[icecleam]

以下のコードで
＞strFromXMLFileName = Dir(varDefaultPath & "*.xls")
この行にブレークを貼り、実行したら値が取れておらず、そのまま一個下に飛んだ後に最終行の
End Sub
まで飛んでいました。

補足
varDefaultPath = wsTo.Cells(1, 4).Value
の位置をご指摘通りに修正したら、エラーは消えました！

ソース
----
Public Sub sample1()

Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
Dim xlsFrom As New Excel.Application ' 取得側Excel
Dim wbFrom As Workbook ' 取得側Excelブック
Dim wsFrom As Worksheet ' 取得側Excelシート
Dim lngFromSheetNo As Long ' 検索するシートの番号
Dim lngFromRowsNo As Long ' 検索する行位置
Dim wsTo As Worksheet ' 設定側Excelシート
Dim lngToRowsNo As Long ' 書きこむ行位置
Dim varKaihatsu As Variant ' [開発]の値

'Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
Dim varDefaultPath As Variant

' コピー先の設定
Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
' 1. コピー先の開始行は2行目から開始とする。
lngToRowsNo = 2 ' 書きこむ行位置2行目から
varDefaultPath = wsTo.Cells(1, 4).Value

' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
'strFromXMLFileName = Dir(strDefaultPath & "*.xls")
strFromXMLFileName = Dir(varDefaultPath & "*.xls")

' Excelファイルが見つからなくなるまで検索
Do Until strFromXMLFileName = ""

' 見つかったExcelブックを開く
'Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
Set wbFrom = Workbooks.Open(varDefaultPath & strFromXMLFileName)

' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
For lngFromSheetNo = 1 To wbFrom.Worksheets.Count

' シート名が"更新"のシートを検索
If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then

' コピー元のシートを設定
Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)

' 2. コピー元のシートを1行目から検索(登録がある行すべて)
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count

If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
' C列=3 が結合セルの場合
Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
Case 4
' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
wsTo.Cells(lngToRowsNo, 3).Value = "担当者" 'C列←"担当者"
wsTo.Cells(lngToRowsNo, 4).Value = wsFrom.Cells(lngFromRowsNo, 5).Value 'D列←E列[年月]1
wsTo.Cells(lngToRowsNo, 5).Value = wsFrom.Cells(lngFromRowsNo, 8).Value 'E列←H列[年月]2
wsTo.Cells(lngToRowsNo, 6).Value = wsFrom.Cells(lngFromRowsNo, 11).Value 'F列←K列[年月]3
wsTo.Cells(lngToRowsNo, 7).Value = wsFrom.Cells(lngFromRowsNo, 14).Value 'G列←N列[年月]4
wsTo.Cells(lngToRowsNo, 8).Value = wsFrom.Cells(lngFromRowsNo, 17).Value 'H列←Q列[年月]5
wsTo.Cells(lngToRowsNo, 9).Value = wsFrom.Cells(lngFromRowsNo, 20).Value 'I列←T列[年月]6
wsTo.Cells(lngToRowsNo, 10).Value = wsFrom.Cells(lngFromRowsNo, 23).Value 'J列←W列[年月]7
wsTo.Cells(lngToRowsNo, 11).Value = wsFrom.Cells(lngFromRowsNo, 26).Value 'K列←Z列[年月]8
wsTo.Cells(lngToRowsNo, 12).Value = wsFrom.Cells(lngFromRowsNo, 29).Value 'L列←AC列[年月]9
wsTo.Cells(lngToRowsNo, 13).Value = wsFrom.Cells(lngFromRowsNo, 32).Value 'M列←AF列[年月]10
' wsTo.Cells(lngToRowsNo, 14).Value = wsFrom.Cells(lngFromRowsNo, 35).Value 'O列←AI列[年月]11
' wsTo.Cells(lngToRowsNo, 15).Value = wsFrom.Cells(lngFromRowsNo, 38).Value 'P列←AL列[年月]12

' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
lngToRowsNo = lngToRowsNo + 1
End If

Case 2
' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
' 5.1. C列に文字列が入っている場合、表の明細として[担当者][工数]の値をコピー先の行へ設定する。
wsTo.Cells(lngToRowsNo, 1).Value = strFromXMLFileName 'A列←ファイル名
wsTo.Cells(lngToRowsNo, 2).Value = varKaihatsu 'B列←開発
wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value 'C列←C列[担当者]
wsTo.Cells(lngToRowsNo, 4).Value = wsFrom.Cells(lngFromRowsNo, 5).Value 'D列←E列[工数]1
wsTo.Cells(lngToRowsNo, 5).Value = wsFrom.Cells(lngFromRowsNo, 8).Value 'E列←H列[工数]2
wsTo.Cells(lngToRowsNo, 6).Value = wsFrom.Cells(lngFromRowsNo, 11).Value 'F列←K列[工数]3
wsTo.Cells(lngToRowsNo, 7).Value = wsFrom.Cells(lngFromRowsNo, 14).Value 'G列←N列[工数]4
wsTo.Cells(lngToRowsNo, 8).Value = wsFrom.Cells(lngFromRowsNo, 17).Value 'H列←Q列[工数]5
wsTo.Cells(lngToRowsNo, 9).Value = wsFrom.Cells(lngFromRowsNo, 20).Value 'I列←T列[工数]6
wsTo.Cells(lngToRowsNo, 10).Value = wsFrom.Cells(lngFromRowsNo, 23).Value 'J列←W列[工数]7
wsTo.Cells(lngToRowsNo, 11).Value = wsFrom.Cells(lngFromRowsNo, 26).Value 'K列←Z列[工数]8
wsTo.Cells(lngToRowsNo, 12).Value = wsFrom.Cells(lngFromRowsNo, 29).Value 'L列←AC列[工数]9
wsTo.Cells(lngToRowsNo, 13).Value = wsFrom.Cells(lngFromRowsNo, 32).Value 'M列←AF列[工数]10
' wsTo.Cells(lngToRowsNo, 14).Value = wsFrom.Cells(lngFromRowsNo, 35).Value 'O列←AI列[工数]11
' wsTo.Cells(lngToRowsNo, 15).Value = wsFrom.Cells(lngFromRowsNo, 38).Value 'P列←AL列[工数]12

' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
lngToRowsNo = lngToRowsNo + 1
End If

End Select
Else
' C列=3 が結合セルでない場合

' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
End If

Next lngFromRowsNo

' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
Exit For

End If

Next lngFromSheetNo

' 見つかったExcelブックを閉じる
Call wbFrom.Close(True) 'セーブはしない
Set wbFrom = Nothing '参照の解除

' 次のExcelファイルを検索
strFromXMLFileName = Dir()
Loop

'----- エラー処理

End Sub

[kuma_kuma_]

ソースを見る限り最終バージョンじゃないけど大丈夫？
※終了処理とかがない