VBAで自動で全体と分析以外のシートを全体に転記

質問

お詳しい方宜しくお願い致します。
一番初めにコードを提供して頂けた方にAmazonギフトコード3,000円提供します。
急ぎでどうしてもエラーがないコードが知りたい為です。

Excelで"全体"と"分析"シート以外のシート(ここでは”A”とB”)を"全体"シートに転記したいです。(添付ファイルはAシートしか載せていません)
以下のコードをマクロで実行すると"全体"シートに集計はちゃんとされていますが、エラーが出ます。

実行時エラー'1004':
'Select' メソッドは失敗しました '_Worksheet'オブジェクト

最初のシートのcellsの行数カウントとシート選択部分が間違えているのが原因のようですが、コードが分からなくて・・・以下、VBAです。
-----------------------------------------------------------
Sub 複数シートのデータを1枚のシートにまとめる_シートオプションあり() '複数シートを１枚
'全体シートがあるか調べる
Dim 貼付シート As Worksheet, あり As Boolean
For Each 貼付シート In Worksheets
If 貼付シート.Name = "全体" Then
あり = True
Exit For
End If
Next 貼付シート
' "全体"が存在しなければメッセージを表示して処理を終了
If あり = False Then
MsgBox "貼り付けシートがありません。終了します。", vbInformation, "エラー"
Exit Sub
End If
'シートの内容クリア
Worksheets("全体").Select
Range("A1").CurrentRegion.Clear
'各シートで処理をする
Dim 枚数 As Long, シート As Worksheet
枚数 = 0
Dim 除外辞書 As Object, 対象辞書 As Object, 配列 As Variant
Dim 除外配列 As Variant, 対象配列 As Variant, 数 As Long
Set 除外辞書 = CreateObject("Scripting.Dictionary")
Set 対象辞書 = CreateObject("Scripting.Dictionary")
'除外配列に、除外対象を代入
配列 = Split("全体,分析", ",")
除外配列 = 配列
For 数 = 0 To UBound(除外配列)
除外辞書.Add 除外配列(数), "除外"
Next 数
'シート名が除外辞書になければ、対象辞書に加える
For Each シート In Worksheets
If Not 除外辞書.Exists(シート.Name) Then
対象辞書.Add シート.Name, "対象"
End If
Next シート
'対象のキーを、配列に入れる
対象配列 = 対象辞書.keys
'配列に入れた対象に、順次処理をする
For Each シート In Worksheets(対象配列)
Call 複数シートのデータを1枚のシートにまとめる(シート, 枚数)
Next
End Sub

Sub 複数シートのデータを1枚のシートにまとめる(シート As Worksheet, 枚数 As Long) '複数シートを１枚
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
Dim 右下セル As String, セル範囲 As String, 貼り付け先範囲 As Range, 貼り付け先セル As String
'シートが"全体"ではない場合、"全体"にデータを貼り付ける
If シート.Name <> "全体" Then
枚数 = 枚数 + 1
'コピーする範囲を取得
シート.Select
Dim 最終行 As Long '表の最終行を決定
最終行 = Cells(Rows.Count, Range("G5").Column).End(xlUp).Row
セル範囲 = "A5" & ":" & Cells(最終行, Range("P5").Column).Address(False, False)
If 枚数 = 1 Then
シート.Range(セル範囲).Copy
Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteAll
Worksheets("全体").Range("A1").PasteSpecial Paste:=xlPasteValues
Else
'表全体の末端を右下セルとして取得
Worksheets("全体").Select
Range("A1").CurrentRegion.Select
右下セル = Cells(Selection.Row + Selection.Rows.Count - 1, Range("A1").Column).Address(False, False)
貼り付け先セル = Worksheets("全体").Range(右下セル).Offset(1, 0).Address(False, False)
シート.Range(セル範囲).Offset(1, 0).Resize(Range(セル範囲).Rows.Count - 1).Copy
Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteAll
Worksheets("全体").Range(貼り付け先セル).PasteSpecial Paste:=xlPasteValues
End If
End If
Worksheets("全体").Activate
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub

回答No.2

kkkkkm · ベストアンサー

> Amazonギフトコードを送ろうと思うのですが、捨てアカウントでも何でも良いのでご希望の送る方法の提案をお願いいたします。

大変ありがたいのですが、お気持ちだけ頂戴します。

お礼

kkkkkmさんかしこまりました。見ず知らずの他人に長ったらしいコードの回答を三回もありがとうございます。実は有料の質問サイトに前日に投稿したのですが、要約すると自分で考えてデバックしろという内容で何も解決しなかったので本当に助かりました！

Powered by GRATICA

回答No.3

kkkkkm

> 回答者にお礼をするのテキストがほかの人に見られないのでしたら

現状ではそのような機能はありませんから絶対に書き込まないでください。
本当にお気持ちだけで大丈夫ですよ。

お礼

かしこまりました。 別のサンクスカードにも書きましたが、有料の質問サイトで本当に塩対応だったので。この長い内容だと何も回答がつかなくても仕方がないなと思っていたので本当にありがとうございました！

Powered by GRATICA

回答No.1

kkkkkm

シート.Selectのところでエラーになっているとの事でしたので

Sub test()
MsgBox Sheets.Count

End Sub

を実行して見えているシートの数と一致するか
もしくは
シート.Select
のところを
MsgBox シート.Name
シート.Select
にして選択しようとしているシート名を確認してみてください。
エラーになった時のシート名が存在するかどうか確認してみてください。

見えないシート名でしたら

Call 複数シートのデータを1枚のシートにまとめる(シート, 枚数)

のところを以下に変更してください。

If シート.Visible = True Then
Call 複数シートのデータを1枚のシートにまとめる(シート, 枚数)
End If

お礼

MsgBox シート.Name
シート.Select

これを入力しましたら、昔に作成した隠しシートが混ざっている事が判明して無事に解決いたしました。

本当にありがとうございました！！

Amazonギフトコードを送ろうと思うのですが、捨てアカウントでも何でも良いのでご希望の送る方法の提案をお願いいたします。

補足

kkkkkmさん
このサイトの細かい使用方法が分かっていないのですが、回答者にお礼をするのテキストがほかの人に見られないのでしたらそこにコードを記載しますが宜しいでしょうか？