エクセルでSheetからSheetへの飛ばし方

質問

Sheet1、Sheet2、Sheet3、Sheet4それぞれに一覧表データが入っています。（一覧表はすべて同じ様式）
この4つのSheetのデータをSheet5に蓄積させるにはどうすればよいでしょうか。
Sheet5を見れば、Sheet1～Sheet4までの全ての一覧表の合体版が見れるようにしたいのですが・・・。蓄積されるデータの順番は問いません。
セルの端にどのSheetからとんできたかは分かるようにしたいです。
教えて下さい。

回答No.7

n-jun · ベストアンサー

もう１点の方が閉じられてしまったのでこちらに。

AdvancedFilterでの一案。

C2～C14の項目をA5～M5に並べ替えて下さい。
注意は、C５～M5の項目名と各学校シートの項目名が一致している事。

検索値の入力は、６行目から１０行目まで対応してます。
必ず上の行から入れて下さい。
例）国語　且つ　教材
６行目の該当項目に　国語　と　教材　を入力します。

例）国語　又は　理科
該当する項目に　６行目に　国語　　７行目に理科　を入力して下さい

例）国語　又は　教材
６行目に　国語　７行目に　教材　です。

６行目の次に８行目に打ち込んだ場合、８行目は無視されます。
検索に有効だったものについては、薄緑色にセルが塗りつぶされます。
６行目を飛ばした場合は、その場で中断します。

新しくシートを作成して”検索シート２”として、コードに学校名を訂正し、
コマンドボタンを作成してから試してみて下さい。

Private Sub CommandButton1_Click()
Dim WS As Worksheet
Dim r As Range
Dim rr As Range, rs As Range
Dim kr As Range, kk As Range
Dim v As Variant, vv As Variant
Dim i As Integer, j As Integer

Set WS = Worksheets("検索シート２")
Set rr = WS.Range("B21")

Set kr = WS.Range("C5")
kr.Resize(6, 11).Interior.ColorIndex = 0

For Each kk In WS.Range("C6:C10")
If WorksheetFunction.CountA(kk.Resize(, 11)) > 0 Then
Set kr = Union(kr, kk)
Else
Exit For
End If
Next

Set kr = kr.Resize(, 11)
If kr.Cells.Count < 12 Then
MsgBox "検索値の入力でミスがあります" & vbLf & _
"中止します"
WS.Range("A20").CurrentRegion.ClearContents
Exit Sub
End If

kr.Interior.ColorIndex = 35
WS.Range("A20").CurrentRegion.ClearContents
WS.Range("A20").Value = "学校名"
WS.Range("B20").Resize(, 12).Value = _
Worksheets("A").Range("A2:L2").Value

' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。

For Each v In Array("A", "B", "C", "D")
With Worksheets(v)
Set r = .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp)).Resize(, 12)
r.AdvancedFilter xlFilterInPlace, kr, , False
Set rs = .Range(.[A3], .Cells(Rows.Count, "A").End(xlUp)).Resize(, 12).SpecialCells(xlCellTypeVisible)

If rs.Item(1).Row <> 2 Then
rs.Copy rr
rr.Offset(, -1).Resize(rs.Cells.Count / 12).Value = v
Set rr = rr.Cells(rs.Rows.Count, 1).Offset(1)
End If
.ShowAllData
End With
Application.CutCopyMode = False
Next
End Sub
うまくいけばいいですが。

お礼

うまくいきました！！お礼遅くなってしまってすみません。
分かりにくい質問にとても親身に回答いただいて本当に感謝しています。ありがとうございました！！

回答No.6

n-jun

>Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
セルＡ２～Ｌの最終行を変数ｒにセット。
⇒Ａ２が開始位置でなければ、それを修正。

２行目が項目行であれば、Ａ３に設定願います。

回答No.5

n-jun

>WS.Range("B1").Resize(, 12).Value = .Range("A1:L1").Value
一番最初のシートのセルＡ１～Ｌ１を”蓄積シート”のＢ１より
右に表示する。
⇒Ａ１～Ｌ１を実際の項目範囲に変更

>Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
セルＡ２～Ｌの最終行を変数ｒにセット。
⇒Ａ２が開始位置でなければ、それを修正。

回答No.4

n-jun

>このマクロは各シートの項目と、入力されているデータが蓄積シートに飛んできます。

WS.Range("B1").Resize(, 12).Value = .Range("A1:L1").Value
Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
この辺りを実際のシートレイアウトにあわせ、変更してもらえば大丈夫
かと思います。

補足

申し訳ありません。
WS.Range("B1").Resize(, 12).Value = .Range("A1:L1").Value
Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
はどういう意味のマクロでしょうか？

回答No.3

n-jun

シート名Ａ～Ｄからシート名”蓄積シート"へ転記する。
シート名Ａ～ＤはＡ列からＬ列までがデータ範囲とする。

Sub Test2()
Dim WS As Worksheet
Dim r As Range
Dim rr As Range
Dim v As Variant

Set WS = Worksheets("蓄積シート")
Set rr = WS.Range("B2")
For Each v In Array("A", "B", "C", "D")

With Worksheets(v)
If v = "A" Then
WS.Range("A1").Value = "シート名"
WS.Range("B1").Resize(, 12).Value = .Range("A1:L1").Value
End If
Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))

End With

r.Copy rr
rr.Offset(, -1).Resize(r.Rows.Count).Value = v
Set rr = rr.Cells(r.Rows.Count, 1).Offset(1)
Application.CutCopyMode = False
Next
End Sub
どうでしょうか？

補足

このマクロは各シートの項目と、入力されているデータが蓄積シートに飛んできます。各シートの項目は飛ばさず、入力されているデータのみ飛ばすことは可能でしょうか？
項目『シート名,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分』は蓄積シートの1行目に入れています。
シート名→○○学校,通し番号→1,区分→国語,機能別分類→教材,品目類→漢字スキル・・・・・のみを蓄積シートに飛ばしたいと思っています。

回答No.2

n-jun

シートが５枚しかなく、左から１～５であり、一番右のシートに蓄積するとする。
１～４のシートには結合セルがなく、１行目は項目であり、蓄積時には
１行目だけ項目行をおく。
蓄積シートの一番右にシート名をつける。

を条件とし、おおざっぱなら、
Sub test()
Dim i As Integer
Dim r As Range
Dim rr As Range

Set rr = Worksheets(Worksheets.Count).Range("A1")
For i = 1 To Worksheets.Count - 1

With Worksheets(i)
If i = 1 Then
Set r = .Range(.[A1], .Cells(Rows.Count, "A").End(xlUp))
Set r = r.Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column)
Else
Set r = .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
Set r = r.Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column)
End If
End With

r.Copy rr
rr.Offset(, r.Columns.Count).Resize(r.Rows.Count).Value = Worksheets(i).Name
Set rr = rr.Cells(r.Rows.Count, "A").Offset(1)
Next
End Sub
ではどうでしょうか？

補足

備品管理のシステムを作っているのでシートは全部で９枚あります。左から検索シート、A、B、C、D、蓄積シート、編集、ラベル、返納書です。蓄積シートには一番左に飛んできたシート名、飛んできたシートの通し番号、飛んできた各項目(区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分)が入るようにしたいです。
ちなみにA,B,C,DのSheetは左に通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分
が入っています。毎回毎回丁寧にありがとうございます。

回答No.1

n-jun

まずは、シートのレイアウトを提示して頂きたく思います。