データ表から条件一致データを抽出し別の1シート表示

質問

エクセルでマスター表から、データを抽出して表示させるのに困っています。
具体的には、下図1のＢ1～Ｄ10のデータ表があり、これをSheet2に下図2のように並べて、11行目から、4列おきに表示させたいのですがどうしたらよいのでしょうか。
以前に類似の質問があり、回答（http://qanda.rakuten.ne.jp/qa6497557.html）を参考にさせていただいたのですが、関数のみで表示され、簡明だったのですが、各々別々のシートに各人を抽出するケースのため、
今回の場合の一つのシートに逐次4列おきに表示しようと、コピーペースト等しても、うまくいきません、また数行下がった位置からスタートするだけで正しい表示がされません。これに使われた関数を何か一工夫する形で、できないでしょうか。
もし難しければ、ＶＢＡで教えていただけないでしょうか。
なお各図の下に示した数式は、上記回答であった数式です。
宜しくお願い致します。

回答No.4

kagakusuki · ベストアンサー

既に、A列という作業列が存在しているのですから、VBAや配列式など使うまでも無く、通常の関数のみで表示させる事は十分に可能です。

　まず、Sheet2のA11セルに次の様な関数を入力して下さい。

=IF((COLUMN()-COLUMN($A$11))/4+1>COUNTIF(マスター!$A:$A,"*-0001"),"",VLOOKUP(IF(COLUMN()-COLUMN($A$11),INDEX($11:$11,COLUMN()-4),"*"),マスター!$A:$B,2,FALSE))

　次に、Sheet2のB11セルに次の様な関数を入力して下さい。

=IF(A11="","",COUNTIF(マスター!$B:$B,A11))

　次に、Sheet2のA13セルに次の様な関数を入力して下さい。

=IF(ROWS($13:13)>SUM(B$11),"",ROWS($13:13))

　次に、Sheet2のB13セルに次の様な関数を入力して下さい。

=IF(INDEX($A$11:B$11,FLOOR(COLUMNS($A:B)-1,4)+1)="","",IF(ROWS($13:13)>INDEX($B$11:B$11,FLOOR(COLUMNS($B:B),4)+1),"",IF(VLOOKUP(INDEX($A$11:B$11,FLOOR(COLUMNS($A:B)-1,4)+1)&TEXT(ROWS($13:13),"-0000"),マスター!$A:$D,MATCH(B$12,マスター!$A$1:$D$1,0),FALSE)="","",VLOOKUP(INDEX($A$11:B$11,FLOOR(COLUMNS($A:B)-1,4)+1)&TEXT(ROWS($13:13),"-0000"),マスター!$A:$D,MATCH(B$12,マスター!$A$1:$D$1,0),FALSE))))

　次に、Sheet2のB13セルをコピーして、Sheet2のC13～D13の範囲に数式のみを貼り付けて下さい。
　次に、Sheet2のA13～D13の範囲をコピーして、同じ列範囲の14行目以下に数式のみを貼り付けて下さい。
　次に、Sheet2のA列～D列をコピーして、E列から初めて右方向に向かって貼り付けて行って下さい。

　以上です。

お礼

お答え有難うございます。
こんな関数式のみで、簡明な形でできるとはおどろきです。
B13の式の意味も、分解して=をつけて試すことでよくわかりました。
今回の仕事には、この数式を使わせていただこうと思います。
有難うございました。

回答No.3

ki-aaa

マスター表のデータ数が沢山ある場合は、次のコードを試してください。

Sub 氏名品名価格配置()

Dim Dic氏名_列 As Object, Dic氏名_件数 As Object
Dim マスター配列, 編集表配列
Dim 最終行 As Long, 表示列 As Long, 個人件数 As Long, 最大個人件数 As Long
Dim i As Long, j As Long, k As Long
Dim myBuff

'実際のシート名に変更
最終行 = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
マスター配列 = Sheets("Sheet1").Cells(2, 2).Resize(最終行 - 1, 3)

Set Dic氏名_列 = CreateObject("Scripting.Dictionary")
Set Dic氏名_件数 = CreateObject("Scripting.Dictionary")

最大個人件数 = 1
表示列 = 0

For i = 1 To UBound(マスター配列)
個人件数 = Dic氏名_件数(マスター配列(i, 1))
If 個人件数 <> 0 Then
個人件数 = 個人件数 + 1
Dic氏名_件数(マスター配列(i, 1)) = 個人件数
If 最大個人件数 < 個人件数 Then
最大個人件数 = 個人件数
End If
Else
表示列 = 表示列 + 4
Dic氏名_列(マスター配列(i, 1)) = 表示列
Dic氏名_件数(マスター配列(i, 1)) = 1
End If
Next i

ReDim 編集表配列(1 To 最大個人件数 + 2, 1 To 表示列)

For i = 1 To UBound(マスター配列)
個人件数 = Dic氏名_件数(マスター配列(i, 1))
表示列 = Dic氏名_列(マスター配列(i, 1))
If 編集表配列(1, 表示列 - 3) = "" Then
編集表配列(1, 表示列 - 3) = マスター配列(i, 1)
編集表配列(1, 表示列 - 2) = 個人件数
個人件数 = 0
End If

個人件数 = 個人件数 + 1
編集表配列(個人件数 + 2, 表示列 - 3) = 個人件数
編集表配列(個人件数 + 2, 表示列 - 2) = マスター配列(i, 1)
編集表配列(個人件数 + 2, 表示列 - 1) = マスター配列(i, 2)
編集表配列(個人件数 + 2, 表示列) = マスター配列(i, 3)

Dic氏名_件数(マスター配列(i, 1)) = 個人件数
Next i

'Sheets("Sheet2").Cells(1, 1)を実状に合せて変える
Sheets("Sheet2").Cells(1, 1).Resize(UBound(編集表配列), UBound(編集表配列, 2)).Value = 編集表配列
Set Dic氏名_列 = Nothing
Set Dic氏名_件数 = Nothing
End Sub

お礼

お答えいただき有難うございます。
大量のデータ数ではためしておりませんが、数十行でしましたが
きちっとできました。
VBAの初心者なので、内容はまだ理解できておりませんので後で読み解きたいと思います。
有難うございました。

回答No.2

tom04

こんばんは！
関数での方法はすでに回答済みですので、VBAでの一例です。

↓の画像で上側が「マスター」Sheetで下側がSheet2とします。
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は使っていない状態にしておいてください。
Sheet2の配置は画像通りとして、2行目の項目は最低限A～D列分だけは入れておいてください。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペースト　→　Excel画面に戻り、マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, cnt As Long, endRow As Long, c As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("マスター")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Rows(1).ClearContents
endRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 2 Then
wS2.Rows(3 & ":" & endRow).ClearContents
End If
wS1.Range("B:B").AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("B:B").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
cnt = cnt + 1
j = (cnt - 1) * 4 + 1
wS2.Cells(1, j) = wS3.Cells(i, "A")
Next i
For j = 5 To wS2.Cells(1, Columns.Count).End(xlToLeft).Column Step 4
wS2.Range("A2").Resize(, 4).Copy wS2.Cells(2, j)
Next j
For i = 2 To wS1.Cells(Rows.Count, "B").End(xlUp).Row
Set c = wS2.Rows(1).Find(what:=wS1.Cells(i, "B"), LookIn:=xlValues, lookat:=xlWhole)
j = c.Column
c.Offset(, 1) = c.Offset(, 1) + 1
wS1.Cells(i, "B").Resize(, 3).Copy wS2.Cells(Rows.Count, j).End(xlUp).Offset(1, 1)
wS2.Cells(Rows.Count, j).End(xlUp).Offset(1) = wS2.Cells(Rows.Count, j).End(xlUp).Row - 1
Next i
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
wS3.Cells.Clear
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

※　関数でないので、マスターSheetの変更があるたびにマクロを実行する必要があります。m(_ _)m

お礼

VBAの回答ありがとうございます。
確かにバッチリと目的のスタイルが出来上がりました。
まだVBAの初心者なので、時間を使って、これから書かれたマクロをきちっと
理解したいと思います。
有難うございました。

回答No.1

bunjii

>今回の場合の一つのシートに逐次4列おきに表示しようと、コピーペースト等しても、うまくいきません
セルのアドレスを相対指定している部分と絶対指定しているところを整理しないとコピー＆ペーストで複製できません。
1名分の表の計算で元データのセル参照を絶対指定にすれば表単位でコピー＆ペーストが可能になります。

添付画像を参考にしてください

B14=IFERROR(INDEX($B$1:$B$10,SMALL(IF($B$2:$B$10=A$12,($B$2:$B$10=A$12)*ROW($B$2:$B$10),""),ROWS($14:14))),"")

C14=IFERROR(INDEX($C$1:$C$10,SMALL(IF($B$2:$B$10=A$12,($B$2:$B$10=A$12)*ROW($B$2:$B$10),""),ROWS($14:14))),"")

D14=IFERROR(INDEX($D$1:$D$10,SMALL(IF($B$2:$B$10=A$12,($B$2:$B$10=A$12)*ROW($B$2:$B$10),""),ROWS($14:14))),"")

3つの式は入れ子のIF関数が配列を返す必要があるため式を入力してCtrl+Shift+Enterで確定します。
B14:D14を下へオートフィルでコピーしました。

お礼

早速のお答え有難うございます。
アドレスの相対指定している部分と絶対指定している部分をかんがえないとできなかったのですか。
大変簡明な関数になってすばらしいです。
もう少しINDEX関数勉強したいと思います。
有難うございました。