VBA 複数条件の抽出

質問

お世話になります。

sheet1～sheet100までのシートがあるとして、
可能とバスケ、普通とバスケがあったら、並んで
バスケ　バスケ
可能　　　普通
という文字を取り出したいです。
文言はいろいろな種類があり、野球、水泳などがあるとします。
それをVBAで行うにはどうすればいいでしょうか。

例）Sheet1
A B
可能 　　バスケ
可能　　野球
不可能　野球
普通　　水泳
普通　　バスケ
可能　　卓球
不可能

こういう表を作りたいです↓
集計シート
A B C D E F G~
　　　　卓球　　卓球　バスケ　バスケ　テニス　野球　水泳
　　　　可能　不可能　　可能　　普通　　可能　不可能　可能
sheet1　　　1 5 6 3 2～
sheet2 2 3 1 1 4
sheet3 4 3 3 3 1
sheet4 1 1 1 1 9
sheet5　 2 3 1 1 4

よろしくお願いいたします。

回答No.3

masnoske

以下のフローで考えてみました．

(1) Sheet1～Sheet100から B列,A列の形式で組合せをコレクションに抽出
(2) 作業シートにコレクションを出力
(3) A列昇順・B列昇順で並べ替える
(4) COUNTIFS関数で集計を作成
(5) 作業シートの行列を入れ替えたデータを結果シートに貼り付ける

Sub Macro1()
Dim sh As Worksheet
Dim shTemp As Worksheet
Dim shResult As Worksheet
Dim col As Collection
Dim str As String
Dim rng As Range
Dim i As Variant
Dim j As Variant
Dim arry As Variant
Dim shMax As Long

shMax = 100
Set shTemp = Worksheets("作業")
Set shResult = Worksheets("集計")

' 組合せをコレクションに抽出する
Set col = New Collection

For i = 1 To shMax
Set sh = Worksheets("Sheet" & i)

For Each rng In sh.Range("A:A")
If rng.Value = "" Then Exit For
str = rng.Offset(0, 1).Value & "," & rng.Value

'
On Error Resume Next
col.Add str, str
On Error GoTo 0
Next
Next

' tempシートの準備
shTemp.Activate
shTemp.Cells.Clear

' コレクションから作業シートに出力する
For i = 1 To col.Count
arry = Split(col(i), ",")
shTemp.Cells(i, 1) = arry(0)
shTemp.Cells(i, 2) = arry(1)
Next

' データを昇順に並べ替える
With shTemp.Sort.SortFields
.Clear
.Add Key:=Range("A:A")
.Add Key:=Range("B:B")
End With

With shTemp.Sort
.SetRange Range("A:B")
.Header = xlGuess
.Apply
End With

' シート行を挿入
shTemp.Range("1:1").Insert

For i = 1 To shMax
shTemp.Cells(1, i + 2).Value = "Sheet" & i
Next

' COUNTIF関数を設定
shTemp.Range("C2") = "=COUNTIFS(INDIRECT(C$1 & ""!B:B""),$A2,INDIRECT(C$1 & ""!A:A""),$B2)"
shTemp.Range("C2").Copy
Range(shTemp.Range("C2"), shTemp.Cells(shTemp.UsedRange.Rows.Count, shTemp.UsedRange.Columns.Count)).PasteSpecial xlPasteFormulas

' 作業シートの行列を入れ替えて結果シートに貼り付ける
shResult.Cells.Clear
shTemp.UsedRange.Copy
shResult.Range("A1").PasteSpecial xlPasteValues, Transpose:=True

' 最終処理
Application.CutCopyMode = False
shTemp.Range("A1").Select
shResult.Activate
shResult.Range("A1").Select
End Sub

回答No.2

HohoPapa

ゴリゴリとコードを書いて、地道に数えるしかないだろうと思います。

・作業シートに、100枚あるらしいシートから
　　シート名、Ａ列語句、Ｂ列語句を集める
・Ａ列語句、Ｂ列語句順に並べ
・2つの語句ごとの出力先列番号を4列目に採番
・シーツ名順に並べ
・各レコードが何枚目のシートのデータかを5列目に採番
・作業シートを先頭から読み取り、
・集計シートに求める集計結果を出力する
といった手順で（ちょっと手抜きですが）コードを書いてみました。

Sub sample()

　Dim wsWork As Worksheet
　Dim wsSyuk As Worksheet
　Dim wshCnt As Long
　Dim RowCnt As Long
　Dim PutCnt As Long
　Dim RetuNum As Long
　Dim SheetNum As Long

　Set wsWork = ThisWorkbook.Sheets("作業")
　Set wsSyuk = ThisWorkbook.Sheets("集計")

　wsWork.Cells.Clear
　wsSyuk.Cells.Clear
　PutCnt = 0

　For wshCnt = 1 To ThisWorkbook.Sheets.Count
　　With ThisWorkbook
　　　If ((.Sheets(wshCnt).Name <> "集計") And (.Sheets(wshCnt).Name <> "作業")) Then
　　　　RowCnt = 1
　　　　Do
　　　　　If .Sheets(wshCnt).Cells(RowCnt, 1).Value = "" Then Exit Do
　　　　　PutCnt = PutCnt + 1
　　　　　wsWork.Cells(PutCnt, 1).Value = .Sheets(wshCnt).Name
　　　　　wsWork.Cells(PutCnt, 2).Value = .Sheets(wshCnt).Cells(RowCnt, 2).Value
　　　　　wsWork.Cells(PutCnt, 3).Value = .Sheets(wshCnt).Cells(RowCnt, 1).Value
　　　　　RowCnt = RowCnt + 1
　　　　Loop
　　　End If
　　End With
　Next wshCnt

　With wsWork
　　.Select
　　.Cells.Select
　　.Sort.SortFields.Clear
　　.Sort.SortFields.Add2 Key:=Range("B:B"), _
　　　　SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　.Sort.SortFields.Add2 Key:=Range("C:C"), _
　　　　SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　With .Sort
　　　.SetRange Range("A:C")
　　　.Header = xlGuess
　　　.MatchCase = False
　　　.Orientation = xlTopToBottom
　　　.SortMethod = xlPinYin
　　　.Apply
　　End With

　　RowCnt = 2
　　RetuNum = 1
　　.Cells(1, 4).Value = RetuNum
　　Do
　　　If .Cells(RowCnt, 1).Value = "" Then Exit Do
　　　If ((.Cells(RowCnt, 2).Value <> .Cells(RowCnt - 1, 2).Value) Or _
　　　　　(.Cells(RowCnt, 3).Value <> .Cells(RowCnt - 1, 3).Value)) Then
　　　　RetuNum = RetuNum + 1
　　　End If
　　　.Cells(RowCnt, 4).Value = RetuNum
　　　RowCnt = RowCnt + 1
　　Loop

　　.Cells.Select
　　.Sort.SortFields.Clear
　　.Sort.SortFields.Add2 Key:=Range("A:A"), _
　　　　SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　With .Sort
　　　.SetRange Range("A:D")
　　　.Header = xlGuess
　　　.MatchCase = False
　　　.Orientation = xlTopToBottom
　　　.SortMethod = xlPinYin
　　　.Apply
　　End With

　　RowCnt = 2
　　SheetNum = 1
　　.Cells(1, 5).Value = SheetNum
　　Do
　　　If .Cells(RowCnt, 1).Value = "" Then Exit Do
　　　If .Cells(RowCnt, 1).Value <> .Cells(RowCnt - 1, 1).Value Then
　　　　SheetNum = SheetNum + 1
　　　End If
　　　.Cells(RowCnt, 5).Value = SheetNum
　　　RowCnt = RowCnt + 1
　　Loop

　End With

　RowCnt = 1
　Do
　　If wsWork.Cells(RowCnt, 1).Value = "" Then Exit Do
　　wsSyuk.Cells(wsWork.Cells(RowCnt, 5).Value + 2, 1).Value = _
　　　wsWork.Cells(RowCnt, 1).Value
　　wsSyuk.Cells(1, wsWork.Cells(RowCnt, 4).Value + 1).Value = _
　　　wsWork.Cells(RowCnt, 2).Value
　　wsSyuk.Cells(2, wsWork.Cells(RowCnt, 4).Value + 1).Value = _
　　　wsWork.Cells(RowCnt, 3).Value

　　wsSyuk.Cells(wsWork.Cells(RowCnt, 5).Value + 2, wsWork.Cells(RowCnt, 4).Value + 1).Value = _
　　wsSyuk.Cells(wsWork.Cells(RowCnt, 5).Value + 2, wsWork.Cells(RowCnt, 4).Value + 1).Value + 1

　　RowCnt = RowCnt + 1
　Loop

End Sub

回答No.1

imogasi

大きく分けると下記の３つの処理ブロックになろう。
（１）件数カウントの最終作業は、
For Each Sh In Worksheets
If Sh.Name <> "集計シート Then
分類カウント処理＝＝＞集計シートにカウント計数を書き込み
Next

で繰り返し処理を行えば、済む。例え１００にワークシートがあろうとも。
（２）B列に出てくる、語句と
　　　A列に出てくる、語句の
１つずつの組み合わせを漏らさず、重複せず、組み合わせを１００シートについて、
リストする。これがむつかしい（泥臭い作業になりそう）
各行について、A列語句＋Ｂ列語句を、中間作業列（例Ｃ列）で作らせてもらえれば
エクセルのフィルタの「重複するレコードは無視する」が、使える。ので楽
だが、どうかな。
この組み合わせを、集計シートの「第２行と第３行」の各列にセットする。

（３）各シートで、集計シートの第２行と第３行の語句の２つを、条件として、
エクセル関数（ＶＢＡ）のCountifs関数を使って数えればよい。
それを集計シートのＳｈｅｅｔ（ｎ）の該当行かつ、該当列にセットする。
＝＝＝＝
（１）（３）は多くの人が思いつくだろう。
しかし（２）はＡ，Ｂ列２列の組み合わせ語句で、出現しているものを
掴むのは、やや面倒。ぴったりの機能がエクセルにはないと思う。
１列データなら、前述エクセルのフィルタの「重複するレコードは無視する」が、使える、
と思う（ＶＢＡで行う）。
＝＝
ピボットテーブルなど思いは及ぶが、自信なし。
ＡＣＣＥＳＳならＳＱＬが使えるので、やや処理がスッキリするかもしれないと夢想。
＝＝＝＝、
質問の書き方(模擬実例の挙げ方）が、正確さに欠けるように思うし、丸投げで、質問者は自分でどこまで」考えたか見えず、データ例も作るのは大変で、シート数も２－３ではないので、コードを作成して、挙げる気がしないよ。
いつもは、第I回答がすぐ出るのに、まだなのは、その辺もあるのでは。-