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
お礼
マクロの記録をとるとかできるんですね！ 知りませんでした。 ばっちりできました。ありがとうございました。