エクセル 複数シートのデータを一つにまとめる

質問

エクセルに関してお知恵を拝借願えれば幸いです。

一つのファイルに多数の（30～96）シートが存在している
エクセルデータがあります。
これらを加工しやすいようにしたいと考えております。

内容としては、
シート１～シート３までは、
同じＡ列に対し、違う内容が示されており（※１）、

（※１）
シート１
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前α　　年齢　　住所・・・

シート２
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前α　　血液型　趣味・・・

シート３
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前α　　特技　　好物・・・

シート４以降は３シートずつ上記のＡ列が変わっていきます。（※２）

（※２）
シート４
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前β　　年齢　　住所・・・

シート５
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前β　　血液型　趣味・・・

シート６
Ａ列　　　　Ｂ列　　　Ｃ列・・・
名前β　　特技　　好物・・・

作業としては二つあり、
作業１：３つのシートに分かれているデータを先頭のシートに一つにまとめる

（シート１）
Ａ列　　　　Ｂ列　　　Ｃ列　　　Ｄ列　　　Ｅ列　　　Ｆ列　　　Ｇ列
名前α　　年齢　　住所　　　血液型　　趣味　　特技　　好物
（シート２）
Ａ列　　　　Ｂ列　　　Ｃ列　　　Ｄ列　　　Ｅ列　　　Ｆ列　　　Ｇ列
名前β　　年齢　　住所　　　血液型　　趣味　　特技　　好物

作業２：上記を一つのシートにまとめる
（シート１）
Ａ列　　　　Ｂ列　　　Ｃ列　　　Ｄ列　　　Ｅ列　　　Ｆ列　　　Ｇ列
名前α　　年齢　　住所　　　血液型　　趣味　　特技　　好物
名前β　　年齢　　住所　　　血液型　　趣味　　特技　　好物

Ａ列の名前の数が違っていたりして、単純に作業記録のやり方のマクロでは
うまくいかず、これらを可能とするマクロについてご助言願えれば幸いです。
よろしくお願い致します。

回答No.5

K Kazz（@JazzCorp） · ベストアンサー

xUnit：組となるシートの数
xColumns：キーを除く項目数／シート
xItems = xUnit * xColumns + 1
初めのお題は、3-2ということです。
シートに複数レコードもケッコウ、、、

Option Explicit
Sub RagPicker()
Const xNameNew = "Master"
Const xUnit = 3
Const xColumns = 2
Const xItems = xUnit * xColumns + 1
Const xHeads = 1
Dim xSheet As Worksheet
Dim xNum As Long
Dim xReply As Long
Dim xLast As Long
Dim xRows As Long
Dim xNoMaster As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
xNum = Sheets.Count
xNoMaster = True
If (xNameNew <> Empty) Then
For Each xSheet In ThisWorkbook.Sheets
If (xSheet.Name = xNameNew) Then
xSheet.UsedRange.Clear
xSheet.Activate
xNum = xSheet.Index - 1
xNoMaster = False
Exit For
End If
Next xSheet
End If
If (xNoMaster) Then
xReply = MsgBox("新しいシートを追加しますか？", vbYesNo)
If (xReply = vbYes) Then
Worksheets.Add after:=Sheets(xNum)
If (xNameNew <> Empty) Then
Sheets(xNum + 1).Name = xNameNew
End If
End If
End If
mm = 1
If (xHeads <> 0) Then
Application.CutCopyMode = False
Sheets(1).Cells(1, "A").Resize(xHeads, xItems).Copy
Cells(1, "A").Resize(xHeads, xItems).PasteSpecial Paste:=xlPasteAll
mm = １+ xHeads
End If
For nn = 1 To xNum Step xUnit
If (Sheets(nn).Name <> xNameNew) Then
xRows = Sheets(nn).Cells(Rows.Count, "A").End(xlUp).Row - xHeads
Cells(mm, "A").Resize(xRows).Value = Sheets(nn).Cells(xHeads + 1, "A").Resize(xRows).Value
For kk = 1 To xUnit
With ActiveSheet
If ((nn + (kk - 1)) > xNum) Then
Exit For
Else
.Cells(mm, 2 + (kk - 1 Mod xUnit) * xColumns).Resize(xRows, xColumns).Value = Sheets(nn + (kk - 1)).Cells(xHeads + 1, "B").Resize(xRows, xColumns).Value
End If
End With
Next kk
Else
nn = nn + 1
If (nn > xNum) Then Exit For
End If
mm = mm + xRows
Next nn
Columns("A").AutoFit
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

回答No.4

K Kazz（@JazzCorp）

行数増えてもそれは簡単に計算できるんで、（Ａ列も含めて）セルを転記してるとこで、resizeの行数に足し込むだけ、
これで軽くやっつけられます。初心者にもやさしいコードなんで、、、

回答No.3

K Kazz（@JazzCorp）

これは２パスではなく、１パスでした。
（デフォルトで）Masterというシートに結果が出る。
元ネタの書き換えは趣味じゃないので、、、

回答No.2

K Kazz（@JazzCorp）

元のシートをつぶすとやり直しができなくなるので、新しいシートを追加してそこで実行すべき。
xNameNewが指定されていれば、それを使う。存在しないときは追加する。
xNameNewが指定されていなければ、シートを追加するか確認する。追加シートは最後尾になる。
追加しないときは、アクティブシートを使う。
ヘッダの処理が必要なら、xHeadsに行数を指定する。

Option Explicit
Sub RagPicker()
Const xNameNew = "Master"
Const xHeads = 0
Dim xSheet As Worksheet
Dim xName As String
Dim xNum As Long
Dim xReply As Long
Dim xNoMaster As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
xName = Sheets(1).Name
xNum = Sheets.Count
xNoMaster = True
If (xNameNew <> Empty) Then
For Each xSheet In ThisWorkbook.Sheets
If (xSheet.Name = xNameNew) Then
xSheet.UsedRange.Clear
xSheet.Activate
xNoMaster = False
Exit For
End If
Next xSheet
End If
If (xNoMaster) Then
xReply = MsgBox("新しいシートを追加しますか？", vbYesNo)
If (xReply = vbYes) Then
Worksheets.Add after:=Sheets(xNum)
If (xNameNew <> Empty) Then
Sheets(xNum + 1).Name = xNameNew
End If
End If
End If
If (xHeads <> 0) Then
Cells(1, "A").Resize(xHeads, 7).Value = Sheets(1).Cells(1, "A").Resize(xHeads, 7).Value
End If
'For each xSheet in thisWorkbook
For nn = 1 To xNum Step 3
If (Sheets(nn).Name <> xNameNew) Then
mm = (nn + 2) / 3 + xHeads
Cells(mm, "A").Value = Sheets(nn).Cells(xHeads + 1, "A").Value
For kk = 1 To 3
With ActiveSheet
If ((nn + (kk - 1)) > xNum) Then
Exit For
Else
.Cells(mm, 2 + (kk - 1 Mod 3) * 2).Resize(1, 2).Value = Sheets(nn + (kk - 1)).Cells(xHeads + 1, "B").Resize(1, 2).Value
End If
End With
Next kk
Else
nn = nn + 1
If (nn > xNum) Then Exit For
End If
Next nn
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます！

やはり元データを残したいなと考えていたので、
かなりうまくいく予感がしております。

ちなみに、

Ａ列　　　　Ｂ列　　　Ｃ列　　　Ｄ列　　　Ｅ列　　　Ｆ列　　　Ｇ列
名前α1　　年齢　　住所　　　血液型　　趣味　　特技　　好物
名前α2
・・・
名前β　　年齢　　住所　　　血液型　　趣味　　特技　　好物

のようにA列のデータの数が複数ある場合や列の種類がさらに
多い場合はどこを変えればよいのでしょうか？
初心者にて的外れな質問をしている場合はご容赦ください。

回答No.1

keithin

たんたんと、ヤリタイ事をやれるマクロを書くだけの作業です。

sub macro1()
　dim i as long
　for i = 1 to worksheeets.count step 3

’あなたの「実際の」レイアウトに応じて適切に修正する事
　worksheets(i + 1).range("B:C").copy worksheets(i).range("D1")
　worksheets(i + 2).range("B:C").copy worksheets(i).range("F1")
’どこ列までデータがあるのか、イチイチ調べなきゃならない状況では無いハズ

　next i
end sub

sub macro2()
　dim i as long
　for i = 4 to worksheets.count step 3

’あなたの「実際の」レイアウトに応じて適切に修正する事
　worksheets(i).range("A2:G" & worksheets(i).range("A65536").end(xlup).row).copy _
　　destination:=worksheets(1).range("A65536").end(xlup).offset(1)
’どこ列までデータがあるのか、イチイチ調べなきゃならない状況では無いハズ

　next i
end sub

お礼

早々のご回答ありがとうございました！

データの中にずれがランダムにあることがわかり、その修正作業が
生じてしまったため、macro1の方は半ばあきらめており
macro2を援用させて頂こうかなと考えております。