セルに入力したパスを参照しファイルを指定ホルダーへ

質問

セル値に入力したパスを参照しファイルを指定ホルダーへコピーしてから、ホルダーへコピーした全ファイル内のデータ数を求めるマクロを作成しており、ファイル添付図内の『カテログデータ総数』シートの[B1:B3]のセル値(『コピー元パス』シートから選択し記載)のホルダー内のファイルを『カテログデータ総数』シートの[B13]のセル値のホルダーへマクロで実行させるコードが分からず大変困っています。
今現在、[B13]のホルダーへは手動でファイルをコピーしている状態です。
※『カテログデータ総数』シート[B1:B12]には、選択した分のパスを記載します。
[B1:B12]のセル値からコピー出来るコードを下記に示しました。
マクロに入れ込んで使えるコードを教えて頂けましたら大変助かります。

Option Explicit

Sub カテログデータ総数求め9()
Dim Sh As Worksheet
Dim FileName As String
Dim ROut As Long

'
'Set Sh = ThisWorkbook.ActiveSheet
Set Sh = Sheets("カテログデータ総数") '2023/10/19設定
ROut = 19
FileName = Dir([B13] & "\*.xls*")
'
If FileName = "" Then
MsgBox "フォルダ又はファイルがありません", vbCritical
End If
Range("B1:B12").Clear
Range("A19:B" & Rows.Count).ClearContents

selectRange

Application.ScreenUpdating = False

'
Do While FileName > ""
Workbooks.Open Sh.[B13] & "\" & FileName, False, True
On Error Resume Next

'オートフィルタ解除(2023/10/19設定)
Sheets(Sh.[B14].Value).AutoFilterMode = False

Sheets(Sh.[B14].Value).Select
'
If Err = 0 Then
Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].SpecialCells(xlCellTypeLastCell).Row - Sh.[B15] + 1
ROut = ROut + 1
End If
On Error GoTo 0
Workbooks(FileName).Close False
FileName = Dir
Loop

'テーブル解除(2023/10/19設定)
On Error GoTo Err_Shori 'テーブルを設定していない場合は、↓処理でエラーが発生するので「Err_Shori」へ飛ぶ
Sh.ListObjects(1).Unlist 'テーブルを設定している場合は、テーブル解除
Err_Shori:

' テーブルを整形
Dim outputTable As ListObject
Set outputTable = Sh.ListObjects.Add(xlSrcRange, Range("A18").CurrentRegion, , xlYes)
outputTable.Name = "OutputTable"
outputTable.TableStyle = "TableStyleMedium9"
'outputTable.HorizontalAlignment = xlCenter

' 総合計を計算して表示
Dim totalCell As Range
Set totalCell = Sh.Range("B16")
totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)
totalCell.HorizontalAlignment = xlCenter
totalCell.Font.Bold = True
totalCell.Borders(xlEdgeTop).LineStyle = xlContinuous

MsgBox ("完了です")

End Sub

'あとから追加
Sub selectRange()

Dim cellRange As Range
Dim ws As Worksheet

Set ws = Sheets("コピー元パス")
On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)

If cellRange Is Nothing Then Exit Sub
cellRange.Select

Set ws = Worksheets("カテログデータ総数")
cellRange.Copy ws.Range("B1")

End Sub

回答No.6

kkkkkm · ベストアンサー

> ・kkkkkmさんからご紹介頂いた『selectRange() As Boolean』の下から4行目へ『ws.Activate』を追加
> したらエラーが出なくなり結果を得られるようになりました。

If selectRange = False Then Exit Sub
Sh.Activate 'これがないと後でエラーになる。

こちらでアクティブにしていたのですが、どちらにしても「カテログデータ総数」がアクティブにできればいいと思います。

なお

selectRange

は

If selectRange = False Then Exit Sub

にしないとコードを変更した意味が無いと思います。
私の考えでは選択をキャンセルした場合それ以上先に進む必要がないと思ってコードを変更しています。

> ・尚、『On Error Resume Next』と『On Error GoTo 0』を全てコメントアウトしましたが、エラー無く正常終了しました。

以前に
「こんなところでOn Error Resume Next使わなくてもシート存在チェックすればいいだけじゃないでしょうか」
と書いたのは元のままのコードではROutが0のままだったので

Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].SpecialCells(xlCellTypeLastCell).Row - Sh.Range("B15") + 1

この2行でエラーになっても無視されて最初のデータが取り込めないまま進んで、次の行でROut + 1になるので以後はエラーにならないが書き込む位置がおかしい…エラーが出ないのでどこが悪いのかわからないという事になりかねません。

シートの有無を先にチェックしてシートがあれば

Sheets(Sh.Range("B14").Value).AutoFilterMode = False
Sheets(Sh.Range("B14").Value).Select

を実行するようにしていれば上記の問題は起こらない(最初にエラーで止まるので)だろうということです。

なお、このシートは開いたブックのシートだと思いますが、このループの中で他のブックをアクティブにしたら別のブックのシートを参照することになると思いますから、注意してください。

で、シートの有無をチェックしなければ『On Error Resume Next』と『On Error GoTo 0』は必要です。
今回エラーにならなかったのはシートが存在したからだと思います。

' On Error Resume Next ' 2023/10/24こちらへ移動させる。
これはいらなくて
Workbooks.Open Sh.Range("B13").Value & "\" & FileName, False, True
の下にあるのでそれを有効にしてください。

これと
' On Error GoTo 0 ' 2023/10/24追加。
これは
' On Error GoTo 0
Workbooks(FileName).Close False
必要です。

これで前述のROutが0の時のエラーを検知するようになります。

Function selectRange() As Boolean
の中の『On Error Resume Next』と『On Error GoTo 0』も必要です。
Application.InputBoxでキャンセルしたらエラーになると思います。

そのコードを実行するときにエラーになる可能性があり、事前にそれを回避する方法がない場合
そのコードを
『On Error Resume Next』と『On Error GoTo 0』で囲む
Application.InputBoxでキャンセルが押されてエラーになるのは事前に回避することができないので「囲む」になっています。

SpecialCells(xlCellTypeLastCell).Row
の最終行取得も注意してください。
今回は問題ないと思いますが
まったく新規のブックで以下を試してみてください。最初は4次にB4にしかデータが無い(削除した)のに8が出ると思います。
Sub test()
Range("B4").Value = "Test"
MsgBox Range("A1").SpecialCells(xlCellTypeLastCell).Row
Range("B8").Value = "Test2"
Range("B8").ClearContents
MsgBox Range("A1").SpecialCells(xlCellTypeLastCell).Row
End Sub

説明の内容が間違っている可能性もありますが、このあたりで終わります。

補足

各コードについて、丁寧に解説頂きまして誠にありがとうございました。ご教示の通りである事、朧気ながらわかるようになりました。更に、ご教示頂きたい処があります。
①Do While FileName > ""のコードを修正しましたが、エラーが出ました。
修正したコードが間違っている事はわかるのですが、正しいコードが分かりませんでした。
Sh.Cells(ROut, "B") = _　と　[A1].SpecialCells(xlCellTypeLastCell).Row -Sh.Range("B15") + 1　は対になっているようです。
Do While FileName > ""
Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1　'←エラー発生、コード修正のご教示お願いします
' [A1].SpecialCells(xlCellTypeLastCell).Row -Sh.Range("B15") + 1
ROut = ROut + 1
End If
②kkkkkmさんからご紹介頂いた　『selectRange』をメーンへ下記のように記載すると『コピー元パス』シートで、コピーするデータ範囲を選択の画面が2回出てしまったので、『If selectRange = False Then Exit Sub』をコメントアウトしたら、画面は1回だけになりました。上記のif文はあった方が良いと言う事ですが、コードを記載する位置が誤っているのでしょうか？　
selectRange
Sh.Activate
If selectRange = False Then Exit Sub
③忠告を頂いている、『なお、このシートは開いたブックのシートだと思いますが、このループの中で他のブックをアクティブにしたら別のブックのシートを参照することになると思いますから、注意してください。』は、おっしゃる通りです。『カテログデータ総数』シート以外を最初に開いたとしても、マクロ実行時に、『カテログデータ総数』をアクテブシートにするようなマクロにする事は可能でしょうか？　もし可能でしたら、何卒ご教示をお願いいたします。　
以下は修正後のマクロのコードになります。
Sub カテログデータ総数求め16()
Dim Sh As Worksheet
Dim FileName As String
Dim ROut As Long
' シートを設定
Set Sh = ThisWorkbook.Sheets("カテログデータ総数")
ROut = 19
Range("B1:B12").Clear
Range("B16").Clear
Range("A19:B" & Rows.Count).ClearContents
' テーブル解除(2023/10/19設定)
On Error GoTo Err_Shori 'テーブルを設定していない場合は処理でエラーが発生する
Sh.ListObjects(1).Unlist 'テーブルを設定している場合は、テーブル解除
' Exit Sub 'テーブル解除したので終了
Err_Shori:
' コピー元ホルダー選択(2023/10/19設定)
selectRange
Sh.Activate 'これがないと後でエラーになる。' 2023/10/28追加
' If selectRange = False Then Exit Sub ' 2023/10/28コピー範囲を2回聞いてくるのでコメントにした。
' B13に記載した作業ホルダー内に*.xlsxファイルが有るか確認する
CheckAndDeleteXLSXFiles
' B1からB12セル値を読み取り、選択したカテログフォルダー内のファイルを作業フォルダへコピー。
CopyFilesToDestinationFolder
Application.ScreenUpdating = False
' カテログファイル名とそのデータ数をアクティブシートへ出力させる
FileName = Dir(Range("B13").Value & "\*.xls*")
'カテログファイルが作業ホルダーにあるか確認する
If FileName = "" Then
MsgBox "フォルダ又はファイルがありません", vbCritical
End If
Do While FileName > ""
Workbooks.Open Sh.Range("B13").Value & "\" & FileName, False, True
On Error Resume Next
' オートフィルタ解除(2023/10/19設定)
Sheets(Sh.Range("B14").Value).AutoFilterMode = False
Sheets(Sh.Range("B14").Value).Select
If Err = 0 Then
' On Error Resume Next ' 2023/10/24こちらへ移動させる。
On Error GoTo 0 ' 2023/10/28必要です。
Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1
' [A1].SpecialCells(xlCellTypeLastCell).Row -Sh.Range("B15") + 1
ROut = ROut + 1
End If
On Error GoTo 0 '2023/10/28必要です。
Workbooks(FileName).Close False
FileName = Dir
Loop
' テーブルを整形
Dim outputTable As ListObject
' On Error Resume Next ' エラーハンドリングを一時的に有効にする
Set outputTable = Sh.ListObjects.Add(xlSrcRange, Range("A18").CurrentRegion, , xlYes)
' On Error GoTo 0 ' エラーハンドリングを元に戻す
outputTable.Name = "OutputTable"
outputTable.TableStyle = "TableStyleMedium9"
' outputTable.HorizontalAlignment = xlCenter
' 総合計を計算して表示
Dim totalCell As Range
Set totalCell = Sh.Range("B16")
' On Error Resume Next
totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)
' On Error GoTo 0
totalCell.HorizontalAlignment = xlCenter
totalCell.Font.Bold = True
totalCell.Borders(xlEdgeTop).LineStyle = xlContinuous
End Sub
' kkkkkm様作成へ変更
Function selectRange() As Boolean
Dim cellRange As Range
Dim ws As Worksheet
Set ws = Sheets("コピー元パス")
ws.Activate ' コピー元パス選択
On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)
On Error GoTo 0 '入れる必要有
If cellRange Is Nothing Then
selectRange = False
Exit Function
End If
cellRange.Select
Set ws = Worksheets("カテログデータ総数")
cellRange.Copy ws.Range("B1")
selectRange = True
End Function

回答No.9

kkkkkm

> Do While Not IsEmpty(R.Value) Or R.HasFormula

空白ではない　もしくは　数式　の場合

Do While Not IsEmpty(R.Value) And R.HasFormula = False

空白ではない　かつ　数式ではない　場合

となるのではないでしょうか。

> →　理解しました、試しに、シート『カテゴリ-ログ』以外のシートで、ファイルを保存してマクロを実施しましたが、

説明する気になりませんので省略します。

元の質問とは離れてきていると思いますので終わりにしてください。

お礼

この度も大変お世話になりまして、心から感謝致します。 最初の質問以外の余計な事までお聞きしてしまい、申し訳ありませんでした。 今回頂きました、忠告やコードの使い方の解説は大変自分の肥やしになりました。

Powered by GRATICA

回答No.8

kkkkkm

> 何かの都合で他のブックやシートを
> Do While FileName > ""
> ：
> Loop
> の中でアクティブにすると問題が起きると思います。

は

何かの都合で他のブックやシートを
Workbooks.Open
:
Workbooks(FileName).Close
の間でアクティブにすると問題が起きると思います。

に訂正です。

補足

注意点等、丁寧に説明をして頂きましてありがとうございます。
毎晩のように、色々とコードを試してみましたが、①については、もう分からなくなってしまいました。
どうか、ご教示を頂けましたら大変助かります。

①A列の最終行でいいのでしたらCells(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1
→　正常に動作しましたありがとうございます。
　今頃になって、大変恐縮なのですが、各ファイルの最終行は、私が手動で削除している為、
　空白や関数式のみがはいった行を残してファイル保存をしている可能性があります。
　その場合を想定して、A列の最終行の文字の次の行以降に空白や関数式のみが入っているセルは無視して
　最終行が文字の行の総行数を求める必要があります。

　下記のように、色々とコードを修正したりしましたが、上記の通りの総行数を求める事が出来ませんでした。
Sh.Cells(ROut, "A") = FileName
Dim LastRow As Long
Dim R As Range
Set R = [A1]
Do While Not IsEmpty(R.Value) Or R.HasFormula

Set R = R.Offset(1, 0)
Loop
LastRow = R.Row - 1
Sh.Cells(ROut, "B") = LastRow - Sh.Range("B15") + 1

例えば、下記のようなデータの場合は、上記のコードでは、『3』となります。
-- データの記載------
装置
装置ID
MM12
=IFERROR(VLOOKUP(B43,装置マスタ!$D:$E,2,FALSE),"")
空白
=IFERROR(VLOOKUP(B43,装置マスタ!$D:$E,2,FALSE),"")
=IFERROR(VLOOKUP(B43,装置マスタ!$D:$E,2,FALSE),"")
空白
----データの記載End-------

②開いたブックのSh.Range("B14").Value(カテゴリーログでしょうか)のシート以外をアクティブにしたら駄目ですという事です。
→　理解しました、試しに、シート『カテゴリ-ログ』以外のシートで、ファイルを保存してマクロを実施しましたが、
　　問題有りませんでした。　認識が違っていたら教えて誤っている所を教えて頂きたいです。

③selectRange　キャンセルしても処理は続行するか
If selectRange = False Then Exit Sub
キャンセルしたら処理をストップするのどちらか一方です。
→ifのコードは、下記のような順序で記載しています。
　if文を入れると、コピー範囲を2回聞かれて2回範囲を選択すると、
　アクティブシート『カテログデータ総数』へ飛ばず、『フォルダ又はファイルがありません』になりました。
　すみません、原因が全く分かりませんので、このコードはコメントにしたいと思います。
　selectRange
　 Sh.Activate
' If selectRange = False Then Exit Sub ←ここをコメントにしないとコピー範囲を2回聞いてくる

回答No.7

kkkkkm

> [A1].(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1　'←エラー発生、

A列の最終行でいいのでしたら
Cells(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1
ですが、もとはシートの利用している全ての列の一番最大の最終行を取得しています。
今回の作業では前回示したテストのようなことは起きないと思いますので、シートの利用している最大の最終行が必要でしたら元のままでいいと思います。
ただ、いつでも元のようなコードでできる事は無いですよという事です。これから先に同じコードで「結果がおかしい」と思う事があったら先のテストを思い出してください。

> 『カテログデータ総数』シート以外を最初に開いたとしても、マクロ実行時に、『カテログデータ総数』をアクテブシートにするようなマクロにする事は可能でしょうか？　

じゃなくて、開いたブックのSh.Range("B14").Value(カテゴリーログでしょうか)のシート以外をアクティブにしたら駄目ですという事です。

Sheets(Sh.Range("B14").Value).Select
のようにどのブックのシートかという指定がない場合アクティブブックのシートを対象にします。
Cells(Rows.Count, 1).End(xlUp).Row - Sh.Range("B15") + 1
これも、シートの指定がないのでアクティブシートのセルを対象にします。

開いたブックが開いた直後にアクティブになる仕様です

現状は、開いたブックのカテゴリーログのシートがアクティブなので問題はないのですが、何かの都合で他のブックやシートを
Do While FileName > ""
：
Loop
の中でアクティブにすると問題が起きると思います。

> 『selectRange』をメーンへ下記のように記載すると『コピー元パス』シートで、コピーするデータ範囲を選択の画面が2回出てしまったので、『If selectRange = False Then Exit Sub』をコメントアウトしたら、画面は1回だけになりました

selectRange
キャンセルしても処理は続行する

か

If selectRange = False Then Exit Sub
キャンセルしたら処理をストップする

のどちらか一方です。

回答No.5

kkkkkm

ROut = 19
FileName = Dir([B13] & "\*.xls*")

'
If FileName = "" Then
MsgBox "フォルダ又はファイルがありません", vbCritical
End If

が無いからだと思います。

動くコードと動かないコードをじっくり観察してみてください。

あと、動く動かないは別として、[B13]なんかもRange("B13").Valueとかに他の所も含めて書き替えたほうがいいと思います。

補足

早速、ご教示を頂きましてありがとうございます。
ご指摘頂いたコード抜けは、丁寧に確認すれば見抜けた箇所で恥ずかしい限りです。
昨夜、コードを修正し、やっとマクロを起動させて結果が得られるようになりました。
このコードで今後使い続けて良い物やら、極めて希薄な私の知識では判断出来ませんの、大変お手数ですが、下記のコードをご確認頂き、修正点などありましたらご教示頂けましたら大変助かります。
この後、アクテブシートへコマンドボタンを作成し、コマンドボタンでマクロを起動させる予定です。

・kkkkkmさんからご紹介頂いた『selectRange() As Boolean』の下から4行目へ『ws.Activate』を追加
したらエラーが出なくなり結果を得られるようになりました。
・尚、『On Error Resume Next』と『On Error GoTo 0』を全てコメントアウトしましたが、エラー無く正常終了しました。

Sub カテログデータ総数求め14()

Dim Sh As Worksheet
Dim FileName As String
Dim ROut As Long

' シートを設定
Set Sh = ThisWorkbook.Sheets("カテログデータ総数")
ROut = 19

Range("B1:B12").Clear
Range("B16").Clear
Range("A19:B" & Rows.Count).ClearContents

' テーブル解除(2023/10/19設定)
On Error GoTo Err_Shori 'テーブルを設定していない場合は処理でエラーが発生するので「Err_Shori」へ飛ぶ
Sh.ListObjects(1).Unlist 'テーブルを設定している場合は、テーブル解除
' Exit Sub 'テーブル解除したので終了
Err_Shori:

' コピー元ホルダー選択(2023/10/19設定)
selectRange

' B13に記載した作業ホルダー内に*.xlsxファイルが有るか確認する
CheckAndDeleteXLSXFiles

' B1からB12セル値を読み取り、選択したカテログフォルダー内のファイルを作業フォルダへコピー。
CopyFilesToDestinationFolder

Application.ScreenUpdating = False

' カテログファイル名とそのデータ数をアクティブシートへ出力させる
FileName = Dir(Range("B13").Value & "\*.xls*")

'カテログファイルが作業ホルダーにあるか確認する
If FileName = "" Then
MsgBox "フォルダ又はファイルがありません", vbCritical
End If

Do While FileName > ""
Workbooks.Open Sh.Range("B13").Value & "\" & FileName, False, True
' On Error Resume Next

' オートフィルタ解除(2023/10/19設定)
Sheets(Sh.Range("B14").Value).AutoFilterMode = False
Sheets(Sh.Range("B14").Value).Select
'
If Err = 0 Then
' ★★★ 『On Error Resume Next』と『On Error GoTo 0』 の間には極力コードを入れない ★★★
' On Error Resume Next ' 2023/10/24こちらへ移動させる。
' On Error GoTo 0 ' 2023/10/24追加。

Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].SpecialCells(xlCellTypeLastCell).Row - Sh.Range("B15") + 1
ROut = ROut + 1
End If

' On Error GoTo 0
Workbooks(FileName).Close False
FileName = Dir
Loop

' テーブルを整形
Dim outputTable As ListObject
' On Error Resume Next ' エラーハンドリングを一時的に有効にする
Set outputTable = Sh.ListObjects.Add(xlSrcRange, Range("A18").CurrentRegion, , xlYes)
' On Error GoTo 0 ' エラーハンドリングを元に戻す
outputTable.Name = "OutputTable"
outputTable.TableStyle = "TableStyleMedium9"
' outputTable.HorizontalAlignment = xlCenter

' 総合計を計算して表示
Dim totalCell As Range
Set totalCell = Sh.Range("B16")
' On Error Resume Next ' エラーハンドリングを一時的に有効にする
totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)
' On Error GoTo 0 ' エラーハンドリングを元に戻す

totalCell.HorizontalAlignment = xlCenter
totalCell.Font.Bold = True
totalCell.Borders(xlEdgeTop).LineStyle = xlContinuous

End Sub

' 2023/10/24 kkkkkm様作成へ変更
Function selectRange() As Boolean
Dim cellRange As Range
Dim ws As Worksheet
Set ws = Sheets("コピー元パス")
ws.Activate ' コピー元パスから選択するのですから
' On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)
' On Error GoTo 0 'ここに入れておかないとこれ以降エラーになってもスルーされます
If cellRange Is Nothing Then
selectRange = False
Exit Function
End If
cellRange.Select
Set ws = Worksheets("カテログデータ総数")
ws.Activate
cellRange.Copy ws.Range("B1")
selectRange = True
End Function

文字数制限の為、以下のサブコードは省略しています。
Sub CopyFilesToDestinationFolder()
Sub CopyFiles(ByVal sourceFolder As String, ByVal destinationFolder As String)
Sub CheckAndDeleteXLSXFiles()

回答No.4

kkkkkm

回答No.3の訂正
On Error GoTo 0
の場所は

If Err = 0 Then
On Error GoTo 0
にも追加したほうがいいと思います

補足

貴重なご教示を頂きましてありがとうございます。
・早速、コードを修正し、ご紹介頂いたサブコード『selectRange』へ入れ替えました。
・出力したファイル名とデータ総数の欄をテーブル形式にしているのは、ファイルの確認をする時ファイル名の順序を変えて確認し易くする為です。
・メーンコードの、選択したカテログフォルダー内のファイルを作業フォルダへコピー』まで問題無く動きました。
しかし、
お察しの通り、何故か下記コードが実行出来ていません。
コードの意味が分からないまま、次々とサブコードを追加した性だと思います。　大変お手数ですが、Whileの所が進まない原因をお気づきでしたらご教示頂けたら大変助かります。
' カテログファイル名とそのデータ数をアクティブシートへ出力させる
Do While FileName > ""

・因みに、下記コードなら辛うじて正常終了出来ています。このマクロは、B1からB12セル値を読み取り作業ホルダーへコピーするコードが分からなかった為、作業ホルダーへは手動でファイルを入れてから実行します。

Option Explicit
Sub カテログデータ総数求め8()
Dim Sh As Worksheet
Dim FileName As String
Dim ROut As Long

'シートを設定
'Set Sh = ThisWorkbook.ActiveSheet
Set Sh = Sheets("カテログデータ総数") '2023/10/19設定
ROut = 19
FileName = Dir([B13] & "\*.xls*")

'
If FileName = "" Then
MsgBox "フォルダ又はファイルがありません", vbCritical
End If
Range("B1:B12").Clear
Range("A19:B" & Rows.Count).ClearContents

' コピー元ホルダー選択(2023/10/19設定)
selectRange

Application.ScreenUpdating = False

'
Do While FileName > ""
Workbooks.Open Sh.[B13] & "\" & FileName, False, True
On Error Resume Next

'オートフィルタ解除(2023/10/19設定)
Sheets(Sh.[B14].Value).AutoFilterMode = False

Sheets(Sh.[B14].Value).Select
'
If Err = 0 Then
Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].SpecialCells(xlCellTypeLastCell).Row - Sh.[B15] + 1
ROut = ROut + 1
End If
On Error GoTo 0
Workbooks(FileName).Close False
FileName = Dir
Loop

'テーブル解除(2023/10/19設定)
On Error GoTo Err_Shori 'テーブルを設定していない場合は、↓処理でエラーが発生するので「Err_Shori」へ飛ぶ
Sh.ListObjects(1).Unlist 'テーブルを設定している場合は、テーブル解除
Err_Shori:

' テーブルを整形
Dim outputTable As ListObject
Set outputTable = Sh.ListObjects.Add(xlSrcRange, Range("A18").CurrentRegion, , xlYes)
outputTable.Name = "OutputTable"
outputTable.TableStyle = "TableStyleMedium9"
'outputTable.HorizontalAlignment = xlCenter

' 総合計を計算して表示
Dim totalCell As Range
Set totalCell = Sh.Range("B16")
totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)
totalCell.HorizontalAlignment = xlCenter
totalCell.Font.Bold = True
totalCell.Borders(xlEdgeTop).LineStyle = xlContinuous

'MsgBox ("完了です")

End Sub

'あとから追加
Sub selectRange()

Dim cellRange As Range
Dim ws As Worksheet

Set ws = Sheets("コピー元パス")
On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)

If cellRange Is Nothing Then Exit Sub
cellRange.Select

Set ws = Worksheets("カテログデータ総数")
cellRange.Copy ws.Range("B1")

End Sub

回答No.3

kkkkkm

Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _

ここ一番最初の実行時にはROutが0なのでエラーですが
On Error Resume Next
でエラー回避しているのでスルーされてます。
On Error GoTo 0
の場所は

If Err = 0 Then
On Error GoTo 0
の方がいいと思います。
On Error Resume Next
と
On Error GoTo 0
の間には極力コードを入れないようにしたほうがいいと思います。
というかこんなところでOn Error Resume Next使わなくてもシート存在チェックすればいいだけじゃないでしょうか。

ただ、それ以前に
Do While FileName > ""
のループに入ってないような気もしますが…。

> 『totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)』でエラーが出てしまい

Range("A19:B" & Rows.Count).ClearContents
で
データ消してその後入力していないので
outputTable.ListColumns(2).DataBodyRange
これはありませんよという事だと思います。(なぜテーブルにしてるのかなぁとか思いますけど)

selectRange
の部分もセル選択でキャンセルしたら先に進んでも意味がないので

If selectRange = False Then Exit Sub
Sh.Activate 'これがないと後でエラーになる。

Function selectRange() As Boolean
Dim cellRange As Range
Dim ws As Worksheet
Set ws = Sheets("コピー元パス")
ws.Activate ' コピー元パスから選択するのですから
On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)
On Error GoTo 0 'ここに入れておかないとこれ以降エラーになってもスルーされます
If cellRange Is Nothing Then
selectRange = False
Exit Function
End If
cellRange.Select
Set ws = Worksheets("カテログデータ総数")
cellRange.Copy ws.Range("B1")
selectRange = True
End Function

他になにかあるかもしれませんが、面倒なのでここまでで。

回答No.2

kkkkkm

回答No.1さんの補足から引用して

> ②『コピー元パス』シートのホルダーパスの記載からコピーするファイルのホルダーパスをApplication.InputBoxで範囲を選択し、アクテブシート[カテログデータ総数]B1～B12へホルダーパスをコピーさせます。

Sub Test()
Dim mRng As Range

Sheets("カテログデータ総数").Range("B1:B12").ClearContents
Sheets("コピー元パス").Activate

On Error Resume Next
Set mRng = Application.InputBox(prompt:="コピー元範囲指定", Type:=8)
On Error GoTo 0
If Not mRng Is Nothing Then
Sheets("カテログデータ総数").Range("B1").Resize(mRng.Rows.Count, 1).Value = mRng.Value
Sheets("カテログデータ総数").Activate
Else
MsgBox "キャンセルされました", vbInformation
End If
End Sub

> ③②のセル値のホルダー内のファイルをアクテブシートB13の作業用ホルダーへコピーします。

以下のサイトを参照してください。

Folderオブジェクト - Copyメソッド
http://officetanaka.net/excel/vba/filesystemobject/folder16.htm
フォルダ内のファイルを、別フォルダへ一括コピペするマクロ【ExcelVBA】
https://vba-create.jp/vba-folder-all-file-copy-paste/

補足

過去にとても親切にマクロのコードを教えて頂き、心より感謝しております。この度も気にかけて下さりありがとうございました。今回、ご質問してから、色々hp上で調べたり、chatgptを活用して、下記のようなコードまで辿り着いたのですが、『カテログファイル名とそのデータ数をアクティブシートへ出力させる』所でアクテブシートへファイル名とデータ数を出力する事で出来ないようで、『totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)』でエラーが出てしまい、対処方法が分からず 困っています。原因がお気づきなりましたら、どうかご教示頂けると大変助かります。
下記はそのコードになりますが、長すぎて最後まで記載する事が出来ませんでした、申し訳ありません。
Sub カテログデータ総数求め12()
Dim Sh As Worksheet
Dim FileName As String
Dim ROut As Long
' シートを設定
Set Sh = ThisWorkbook.Sheets("カテログデータ総数")
Range("B1:B12").Clear
Range("A19:B" & Rows.Count).ClearContents
' コピー元ホルダー選択(2023/10/19設定)
selectRange
' B13に記載した作業ホルダー内に*.xlsxファイルが有るか確認する
CheckAndDeleteXLSXFiles
' B1からB12セル値を読み取り、選択したカテログフォルダー内のファイルを作業フォルダへコピー。
CopyFilesToDestinationFolder
Application.ScreenUpdating = False
' カテログファイル名とそのデータ数をアクティブシートへ出力させる
Do While FileName > ""
Workbooks.Open Sh.[B13] & "\" & FileName, False, True
On Error Resume Next
'オートフィルタ解除(2023/10/19設定)
Sheets(Sh.[B14].Value).AutoFilterMode = False
Sheets(Sh.[B14].Value).Select
If Err = 0 Then
Sh.Cells(ROut, "A") = FileName
Sh.Cells(ROut, "B") = _
[A1].SpecialCells(xlCellTypeLastCell).Row - Sh.[B15] + 1
ROut = ROut + 1
End If
On Error GoTo 0
Workbooks(FileName).Close False
FileName = Dir
Loop
'テーブル解除(2023/10/19設定)
On Error GoTo Err_Shori 'テーブルを設定していない場合は処理でエラーが発生するので「Err_Shori」へ飛ぶ
Sh.ListObjects(1).Unlist 'テーブルを設定している場合は、テーブル解除
Exit Sub 'テーブル解除したので終了
Err_Shori:
' テーブルを整形
Dim outputTable As ListObject
Set outputTable = Sh.ListObjects.Add(xlSrcRange, Range("A18").CurrentRegion, , xlYes)
outputTable.Name = "OutputTable"
outputTable.TableStyle = "TableStyleMedium9"
'outputTable.HorizontalAlignment = xlCenter
' 総合計を計算して表示
Dim totalCell As Range
Set totalCell = Sh.Range("B16")
'On Error Resume Next ' エラーハンドリングを一時的に有効にする
totalCell.Value = Application.WorksheetFunction.Sum(outputTable.ListColumns(2).DataBodyRange)
'On Error GoTo 0 ' エラーハンドリングを元に戻す
totalCell.HorizontalAlignment = xlCenter
totalCell.Font.Bold = True
totalCell.Borders(xlEdgeTop).LineStyle = xlContinuous
End Sub
Sub selectRange()
Dim cellRange As Range
Dim ws As Worksheet
Set ws = Sheets("コピー元パス")
On Error Resume Next
Set cellRange = Application.InputBox("シート【コピー元パス】から、処理範囲をドラッグして選択してください", "処理範囲の指定", Type:=8)
If cellRange Is Nothing Then Exit Sub
cellRange.Select
Set ws = Worksheets("カテログデータ総数")
cellRange.Copy ws.Range("B1")
End Sub
Sub CopyFilesToDestinationFolder()
Dim ws As Worksheet
Dim destFolder As String
Dim sourcePaths() As Variant
Dim i As Integer
' Set the destination folder from cell B13
Set ws = Sheets("カテログデータ総数")
destFolder = ws.Range("B13").Value
' Read the source folder paths from cells B1 to B12
ReDim sourcePaths(1 To 12)
For i = 1 To 12
sourcePaths(i) = ws.Range("B" & i).Value
Next i
' Copy files from source paths to the destination folder
For i = 1 To 12
If sourcePaths(i) <> "" Then
CopyFiles sourcePaths(i), destFolder
End If
Next i
End Sub

回答No.1

noname#258475

セルの記述も一貫性がないしOn Errorもなんか安易に使ってそうだし
意味もよく分からずに適当に追加でコピペしてるんじゃないかなぁ
このまま追加変更していっても最終的に泥沼に入るだけだと思うよ
一から出直した方がいいね

説明もだらだらと一文で書かずに箇条書きにした方が分かりやすいと思うけど、まかり間違って余程暇な人がコードを示してくれるかもだねぇ

頑張ってください

補足

ご意見ありがとうございました。マクロの作用順序を以下のように纏めて見ました。
①作業ホルダーへコピーするエクセルのファイルは、下記の2023年度ホルダーへ1ヶ月毎に保存されています。
　このホルダーパスを『コピー元パス』シートへ記載しておきます。
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_04月\チェック完了\*
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_05月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_06月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_07月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_08月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_09月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_10月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_11月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\_12月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\01月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\02月\チェック完了\
\\w\tech-division\01.カテ１登録装置利用記録簿\R05年度\_00.提出用フォルダ\03月\チェック完了\
②『コピー元パス』シートのホルダーパスの記載からコピーするファイルのホルダーパスをApplication.InputBoxで範囲を選択し、アクテブシート[カテログデータ総数]B1～B12へホルダーパスをコピーさせます。
例えば、3ヶ月間の選択は、B1～B3にホルダーパスがコピーされ、B4～B12は空白のままになります。　
③②のセル値のホルダー内のファイルをアクテブシートB13の作業用ホルダーへコピーします。
コピー範囲はApplication.InputBoxで選択した範囲である事と、B1～B12のセルは空白が存在してしまい、一貫性がありません。
この作業をさせるコードが分からず困っております。　
④これ以降の、作業ホルダー中ファイルの総数を求めるコードは、正常に動く事が確認出来ていますので、説明は省略させて頂きました。