【VBA】複数シートから抜き出したデータを集約

質問

【Excel2010】の
　●同一ブック内で、
　●sheet1～9の同一列から、
　●sheet10の任意列へ、
　●データを抜き出して、続けて表示させたい
と思っています。

手動オートフィルタや、関数で試しましたが、
作業のたびにかなりの手間になります。
願わくばVBAマクロで対応できればと思っているのですが、
知識不足のため、うまくできませんでした。

具体的な画面も添付させていただきます。
ご教示いただきたく、よろしくお願いいたします。

＜補足＞
sheet1～9のデータ行範囲は作業ごと・シートごとに変わります。
（データ列は固定です）

回答No.1

kkkkkm · ベストアンサー

シートは左端からSheet1~Sheet10まで間に別のシートはなく並んでいるとして(シート名は問わない)
Sheet10の2行目から詰めて転記します。コピー貼り付けはしません(短時間で頻繁にコピー貼り付けするとエラーになることがあるみたいです)

Sub Test()
Dim i As Long, j As Long
Dim LastRow As Long, AL As Long, BL As Long
Dim sh10ALastRow As Long, sh10BLastRow As Long
Dim ShW As Worksheet, ShR As Worksheet

Set ShW = Sheets(10)

sh10ALastRow = ShW.Cells(Rows.Count, "A").End(xlUp).Row
sh10BLastRow = ShW.Cells(Rows.Count, "B").End(xlUp).Row
AL = 1: BL = 1
For i = 1 To 9
Set ShR = Sheets(i)
LastRow = ShR.Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To LastRow
If ShR.Cells(j, "J").Value <> "" Then
ShW.Cells(sh10ALastRow + AL, "A").Value = ShR.Cells(j, "J").Value
AL = AL + 1
End If
If ShR.Cells(j, "K").Value <> "" Then
ShW.Cells(sh10BLastRow + BL, "B").Value = ShR.Cells(j, "K").Value
BL = BL + 1
End If
Next j
Set ShR = Nothing
Next i
Set ShW = Nothing
End Sub

お礼

kkkkkm 様

この度は早々に回答いただきまして、誠にありがとうございました。
ご教示いただいたコードを元に、無事解決することができました。
大変助かりました。
ありがとうございます。

まだまだ勉強を始めたばかりの初心者ですので、また別の質問をすることもあるかと思います。
もしお時間許されましたら、是非またお力添えいただきたくお願い申し上げます。

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

回答No.4

nishi6

Sheet1～Sheet9のJ、K列のデータを抽出（添付図の通り）
　　↓
それぞれをSheet10のA、B列に連続的に貼り付け（添付図の通り）
　　↓
貼り付け結果で空白セルがあったら削除して上に詰める（添付図の通り）

というマクロです。見てわかるように書いたつもりですがどうでしょうか。Sheet11以降があっても構いません。

回答の添付図は、チェックしやすいデータを入力し、Sheet10が問題なく集計されているのを確認しています。
ループの個所を除けば、「データ取り込み」、「データ貼り付け」、「空白削除」の３、４行のマクロです。変数の定義をちゃんと行い、Excelの機能を使えば、マクロも簡略化できるということですね。標準モジュールに貼り付けます。当方、Win10、Excel2010です。ご参考に。

Sub shtJoin()
　Dim w As Integer, Ary(9) As Variant
　For w = 1 To 9　'// データを取り込む
　　Ary(w) = Worksheets("Sheet" & w).Range("J2:K" & maxRw(w))
　Next

　Worksheets("Sheet10").Activate
　Range("A2:B" & Rows.Count).ClearContents　'// クリア
　For w = 1 To 9　'// データ貼り付け
　　Range("A" & maxRw(10) & ":" & _
　　　　　"B" & maxRw(10) + UBound(Ary(w)) - 1) = Ary(w)
　Next

　Range("A2:B" & maxRw(10)). _
　　　SpecialCells(xlCellTypeBlanks).Select '// 空白を選択
　Selection.Delete Shift:=xlUp: Range("A1").Select　'// 削除
End Sub

　Function maxRw(ShtNo As Integer) '// A、B列の最下行を取得
　　With Worksheets("Sheet" & ShtNo)
　　　maxRw = WorksheetFunction.Max( _
　　　　　Range("A" & .Rows.Count).End(xlUp).row, _
　　　　　Range("B" & .Rows.Count).End(xlUp).row) + 1
　　End With
　End Function

お礼

nishi6 様

この度は詳細に画面キャプチャまでご提供いただきまして、誠にありがとうございました。
キャプチャを拝見し、ご教示いただいたコードを理解することができました。

一番最初に回答いただいた方をベストアンサーとさせていただきましたが、大変心苦しく思います。
本当にありがとうございました。

まだまだ勉強を始めたばかりの初心者ですので、また別の質問をすることもあるかと思います。
もしお時間許されましたら、是非またお力添えいただきたくお願い申し上げます。

回答No.3

imogasi

既出回答と考え方は同じだが、ＶＢＡのコード行数が少ない。繰り返しの記述が
最小限（Ｃｏｐｙ貼り付けを使うことで）
Sub test01()
Set tsh = Worksheets("Sheet3") '集約シート
'--
For Each sh In Worksheets
If sh.Name <> "Sheet3" Then
lr = sh.Cells(100000, "B").End(xlUp).Row
lr2 = tsh.Cells(100000, "B").End(xlUp).Row
sh.Range(sh.Cells(2, "B"), sh.Cells(lr, "B")).Copy tsh.Cells(lr2 + 1, "B")
End If
Next
End Sub
集約シート名Sheet3
と
列番号のＢは適宜質問者のばあいで修正されたい」。
各シートのデータは10万行以下、このブックには、集約されるシートと集約するシート以外は置いてないとしている。
sheet1～9に意味を持たせるなら、シートタブ的に左にＭＯＶしておいて
ＦｏｒＮｅｘｔを使えば同程度の行数になる。

お礼

imogasi 様

この度はご教示いただきまして、誠にありがとうございました。
大変助かりました。

一番最初に回答いただいた方をベストアンサーとさせていただきましたが、大変心苦しく思っております。
本当にありがとうございました。

また別の質問をすることもあるかと思いますので、もしお時間許されましたら、是非またお力添えいただきたくお願い申し上げます。

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

回答No.2

oboroxx

同じものがあるという仮定で作りました。

Option Explicit

Public Sub TestMacro()
Const CONST_YASAI_COL As Integer = 10
Const CONST_KUDAMONO_COL As Integer = 11
Dim ws As Worksheet
Dim rng As Range
Dim a As Integer
Dim i As Long
Dim j As Long
Dim rowMax As Long

For a = 1 To 9
Set ws = ThisWorkbook.Worksheets(a)

With ws
rowMax = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = 2 To rowMax
'野菜
If .Cells(i, CONST_YASAI_COL).Value <> "" Then
WriteData .Cells(i, CONST_YASAI_COL).Value, 1

End If

'くだもの
If .Cells(i, CONST_KUDAMONO_COL).Value <> "" Then
WriteData .Cells(i, CONST_KUDAMONO_COL).Value, 2
End If

Next i
End With

Set ws = Nothing
Next a

End Sub

Private Sub WriteData(ByVal data As String, ByVal col As Integer)
Dim i As Long
Dim blnMatch As Boolean
Dim k As Long

i = 2
blnMatch = False
'チェック用
Debug.Print data

With Worksheets("Sheet10")
Do While .Cells(i, col) <> ""
If .Cells(i, col).Value = data Then
blnMatch = True
Exit Do
End If

i = i + 1
Loop

If blnMatch = False Then
k = .Cells(.Rows.Count, col).End(xlUp).Row + 1
.Cells(k, col).Value = data
End If
End With

End Sub

お礼

oboroxx 様

この度はご教示いただきまして、誠にありがとうございました。

一番最初に回答いただいた方のコードを採用させていただきましたが、ご教示いただいたコードでも無事解決することができました。大変勉強になりました。
ありがとうございました。

まだまだ勉強を始めたばかりの初心者ですので、また別の質問をすることもあるかと思います。
もしお時間許されましたら、是非またお力添えいただきたくお願い申し上げます。

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