ExcelVBAで複数条件で抽出して表を作成

ExcelVBAで複数条件一致の時の抽出法方を教えて下さい。

ここで教えていただいたコードがあるのですが、質問の仕方が悪かったのか、意図した結果が得られず、改変もできなかったので再質問です。よろしくお願い致します。

質問をすることは会社の許諾を得ているのですが、会社のPCからは制限がかかっており投稿できないのでスマホからです。なるべく伝わりやすいよう努めますが、力不足なときはお許し下さい。

Excelのオートフィルタ機能でもよいとも思ったのですが、処理数が100を越えるため、VBAを検討することにしました。

(1)処理前の並び順と、VBAで処理した後の並び順は異なります。
処理前：コードの昇順
処理後：地域ごとに表を作成し、更に広域ごとに表を掲載するシートを分ける

(2)処理前の表は数字しか並んでいません。全てコード化しています。

(3)処理前はいくつもの地域の男女の値が表になっていますが、
・地域コード
・性別コード
・年代コード
・疾患コード
で抽出して、表を作る方法を教えて下さい。1つの地域を抽出する方法で良いのでお願い致します。
後は表を配置する場所と地域コードを指定して、自力で頑張ります。

<元データ>
---|-A-|-B-|-C-|-D-|-E-|-F-|-G-|
列|地域| 性 | 年 | 21 | 22 | 23| 24 |
01| 201 | 1 | 40 | 1 | 2 | 3 | 4 |
02| 201 | 1 | 50 | 2 | 4 | 2 | 1 |
03| 201 | 1 | 55 | 3 | 0 | 0 | 7 |
04| 201 | 1 | 65 | 2 | 1 | 1 | 6 |
05| 201 | 1 | 80 | 1 | 2 | 4 | 1 |
06| 201 | 1 | 95 | 7 | 5 | 4 | 3 |
07| 201 | 2 | 45 | 0 | 3 | 3 | 0 |
08| 201 | 2 | 60 | 4 | 2 | 2 | 6 |
09| 201 | 2 | 70 | 1 | 2 | 3 | 4 |
10| 201 | 2 | 75 | 3 | 6 | 0 | 3 |
11| 201 | 2 | 85 | 5 | 2 | 4 | 2 |
12| 201 | 2 |100| 2 | 2 | 1 | 0 |
13| 202 | 1 | 40 | 1 | 2 | 3 | 4 |
14| 202 | 1 | 45 | 3 | 5 | 2 | 7 |
15| 202 | 1 | 55 | 1 | 2 | 3 | 2 |
…続く
・A列は地域コードです。
・B列は性別コードです。男性が「1」女性が「2」です。
・C列は年代コードです。
40/45/50/55/60/65/70/75/80/85/90/95/100
という形に40から100まで5歳刻みです。
・D列～G列は疾病コードです。

<希望>
・元データの年代は値がないと表示がありません。ですが、出力される表には全ての年代を表示させるのが希望です。

<処理後の表>
VBA実行後は、以下のような表が1つ作成できることが希望です。教えていただいたコードを元に、配置場所を変更できるようになっていると大変ありがたいです。

01| 201 |----| 21 | 22 | 23 | 24 |合計|
02|男性 | 40 | 1 | 2 | 3 | 4 | 10 |
03|男性 | 45 |-----|-----|-----|----| 0 |
04|男性 | 50 | 2 | 4 | 2 | 1 | 9 |
05|男性 | 55 | 3 | 0 | 0 | 7 | 10 |
06|男性 | 60 |-----|-----|-----|----| 0 |
07|男性 | 65 | 2 | 1 | 1 | 6 | 10 |
08|男性 | 70 |-----|-----|-----|----| 0 |
09|男性 | 75 |-----|-----|-----|----| 0 |
10|男性 | 80 | 1 | 2 | 4 | 1 | 8 |
11|男性 | 85 |-----|-----|-----|----| 0 |
12|男性 | 90 |-----|-----|-----|----| 0 |
13|男性 | 95 | 7 | 5 | 4 | 3 | 19 |
14|男性 |100|-----|-----|-----|----| 0 |
15|男性 |合計| 16 | 14 | 14 | 22| 66 |
16|女性 | 40 |-----|-----|-----|----| 0 |
17|女性 | 45 | 0 | 3 | 3 | 0 | 6 |
18|女性 | 50 |-----|-----|-----|-----| 0 |
19|女性 | 55 |-----|-----|-----|-----| 0 |
20|女性 | 60 | 4 | 2 | 2 | 6 | 14 |
21|女性 | 65 |-----|-----|-----|-----| 0 |
22|女性 | 70 | 1 | 2 | 3 | 4 | 10 |
23|女性 | 75 | 3 | 6 | 0 | 3 | 12 |
24|女性 | 80 |-----|-----|-----|-----| 0 |
25|女性 | 85 | 5 | 2 | 4 | 2 | 13 |
26|女性 | 90 |-----|-----|-----|-----| 0 |
27|女性 | 95 |-----|-----|-----|-----| 0 |
28|女性 |100| 2 | 2 | 1 | 0 | 5 |
29|女性 |合計| 15 | 17 | 13 | 15 | 60 |

こんな表にしたいです。
縦横のそれぞれの合計が出せると素敵です。

お知恵を拝借したく、何卒、よろしくお願い致します。

No.3 ベストアンサー 回答者： end-u 回答日時： 2014/01/31 00:18

やりたい事と少し方向性が違うかもしれませんが、PivotTableを使ったアプローチ。

1)ActiveWorkbookに対して処理を行う。
2)ActiveWorkbookに「元データ」という名前のシートがあり、データはそのＡ１セルが起点。
3)Ａ列は空白セルがない連続データであり、データ行数をＡ列の個数で判断できる。
4)１行目は空白セルがない連続データであり、データ列数を１行目の個数で判断できる。
5)A1:C1セルに "地域","性","年" という項目名がある。
以上を前提条件とします。

Sub Macro1()
　　Dim pt As PivotTable
　　Dim i　As Long

　　With ActiveWorkbook
　　　　.Names.Add Name:="database", RefersToR1C1:="=INDEX(元データ!R1,COUNTA(元データ!R1)):INDEX(元データ!C1,COUNTA(元データ!C1))"
　　　　Set pt = .PivotCaches.Add(SourceType:=xlDatabase, SourceData:="database").CreatePivotTable("")
　　End With
　　pt.AddFields RowFields:=Array("性", "年"), ColumnFields:="データ", PageFields:="地域"
　　For i = 4 To Range("database").Columns.Count
　　　　pt.AddDataField pt.PivotFields(i), , xlSum
　　Next
　　With pt.PivotFields("性")
　　　　.PivotItems("1").Caption = "男性"
　　　　.PivotItems("2").Caption = "女性"
　　　　.ShowAllItems = True
　　End With
　　pt.PivotFields("年").ShowAllItems = True
End Sub

この回答への補足

ありがとうございます。ですが、全ての合計を出したいのではなく、1つの地域コードを指定して、表を作成したいのです。ピポットテーブルは検討しましたが、100近くある地域コードについてそれぞれやるのには不向きと思い止めた経緯があります。

補足日時：2014/02/03 17:46

この回答へのお礼

地域コードが選択できることに気づきませんでした(^_^;)スミマセン…ちょっと手間ですが、形式を指定して貼付で「値だけ」にして地道に表をレイアウトしていきたいと思います。ちょっと急ぎなので、この回答が今の私に一番良さそうです。発想の転換でした！ありがとうございました！

お礼日時：2014/02/03 17:57

No.4 回答者： tom04 回答日時： 2014/01/31 22:37

No.1．2です。

たびたびごめんなさい。
各地域ごとで男女別の合計が必要なのですね！
前回は単に総合計だけでしたので、無視して↓のコードにしてください。
今回もSheet3を作業用のSheetとして使用しています。
Sheet1のデータは2行目以降にあるとします。

Sub Sample2()
Dim i As Long, j As Long, k As Long, endRow As Long
Dim c As Range, myRange As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells.Clear
With Worksheets("Sheet3")
wS1.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").SpecialCells(xlCellTypeVisible).Copy .Range("A1")
wS1.ShowAllData
wS1.Range("B1").Resize(, 6).Copy .Range("C1")
.Range("I1") = "合計"
.Range("A1").Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
For k = 2 To 14
.Cells(k, "B") = (k - 2) * 5 + 40
Next k
.Cells(15, "D") = "合計"
Set myRange = .Range("C2:H14")

For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
.Range("C1") = .Cells(i, "A")
wS1.Range("A1").AutoFilter field:=1, Criteria1:=.Cells(i, "A")
wS1.Range("A1").AutoFilter field:=2, Criteria1:="1"
.Range("C15") = .Cells(i, "A") & "男性"
Range(wS1.Cells(1, "A"), wS1.Cells(endRow, "G")).SpecialCells(xlCellTypeVisible).Copy .Range("J1")
For k = 2 To 14
Set c = .Range("L:L").Find(what:=.Cells(k, "B"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Cells(c.Row, "K").Resize(, 6).Copy .Cells(k, "C")
Else
.Cells(k, "C") = 1
.Cells(k, "D") = .Cells(k, "B")
End If
Next k
With .Range("I2:I14")
.Formula = "=SUM(E2:H2)"
.Value = .Value
End With
With .Range("E15:I15")
.Formula = "=SUM(E2:E14)"
.Value = .Value
End With
.Range("C1:I15").Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Range("J1:P14").ClearContents
myRange.ClearContents
wS1.Range("A1").AutoFilter field:=1, Criteria1:=.Cells(i, "A")
wS1.Range("A1").AutoFilter field:=2, Criteria1:="2"
.Range("C15") = .Cells(i, "A") & "女性"
Range(wS1.Cells(1, "A"), wS1.Cells(endRow, "G")).SpecialCells(xlCellTypeVisible).Copy .Range("J1")
For k = 2 To 14
Set c = .Range("L:L").Find(what:=.Cells(k, "B"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Cells(c.Row, "K").Resize(, 6).Copy .Cells(k, "C")
Else
.Cells(k, "C") = 2
.Cells(k, "D") = .Cells(k, "B")
End If
Next k
With .Range("I2:I14")
.Formula = "=SUM(E2:H2)"
.Value = .Value
End With
With .Range("E15:I15")
.Formula = "=SUM(E2:E14)"
.Value = .Value
End With
.Range("C2:I15").Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Range("J1:P14").ClearContents
myRange.ClearContents
Next i
wS1.AutoFilterMode = False
.Cells.Clear
End With
With wS2.Range("A:A")
.Replace what:=1, replacement:="男性", lookat:=xlWhole
.Replace what:=2, replacement:="女性", lookat:=xlWhole
End With
With wS2
.Rows(1).Delete
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Columns.AutoFit
End With
Application.ScreenUpdating = True
wS2.Select
MsgBox "処理完了"
End Sub

※　すべての地域を羅列するようにしていますので、
時間を要すると思います。m(_ _)m

この回答へのお礼

ありがとうございます。せっかく書いていただきましたが、表しか作成されませんでした(;_;)それと、表を羅列したいのではなく、地域コードを指定して1つだけ表を作りたいのです。総数を出したいのは書いていただいたとおり希望ですが、それはどうにかなるので、1つの地域コードを指定して表を出力するにはどうしたらいいのか教えて下さい_(._.)_

お礼日時：2014/02/03 17:43

No.2 回答者： tom04 回答日時： 2014/01/30 23:48

続けて・・・後半部分です。

wS3.Range("B1:H14").Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
myRange.ClearContents
wS3.Range("I:O").Clear
.AutoFilter field:=2, Criteria1:=2
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow, "G")).Copy wS3.Range("I1")
For k = 2 To 14
Set c = wS3.Range("K:K").Find(what:=wS3.Cells(k, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
wS3.Cells(c.Row, "J").Resize(, 6).Copy wS3.Cells(k, "B")
Else
With wS3.Cells(k, "B")
.Value = 2
.Offset(, 1) = wS3.Cells(k, "A")
End With
End If
Next k
With wS3.Range("H2").Resize(13)
.Formula = "=SUM(D2:G2)"
.Value = .Value
End With
wS3.Range("B2:H14").Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
myRange.ClearContents
wS3.Range("I:O").Clear
End With
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
With wS2
.Rows(1).Delete
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Cells(endRow, "A").Offset(1) = "合計"
Set c = Range(.Cells(1, "A"), .Cells(endRow, "A"))
For k = 3 To 7
Set myRange = Range(.Cells(1, k), .Cells(endRow, k))
.Cells(endRow + 1, k) = WorksheetFunction.SumIf(c, 1, myRange) + _
WorksheetFunction.SumIf(c, 2, myRange)
Next k
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("A:A").Replace what:=1, replacement:="男性", lookat:=xlWhole
.Range("A:A").Replace what:=2, replacement:="女性", lookat:=xlWhole
End With
Application.ScreenUpdating = True
wS2.Select
MsgBox "処理完了"
End Sub

じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

ありがとうございます。試してみたのですが、表はきれいにできるのですが、結果は抽出されませんでした。それと、表は地域コード1つだけで作りたいので、羅列はしなくてよいのです。説明が下手で申し訳ありません_(._.)_1つだけで出力するにはどうしたらよいか、教えていただけますと幸いです。

お礼日時：2014/02/03 17:50

No.1 回答者： tom04 回答日時： 2014/01/30 23:46

こんばんは！

Sheet1のデータをSheet2に表示するようにしています。、
Sheet見出し上には3つSheetがあり、Sheet3は使用していない状態にしておいてください。
Sheet1は1行目が項目行でデータは2行目以降にあるとします。

↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。
ただ、ダラダラと長いコードになってしまいましたので、
2回に分けて投稿します。

まず前半部分

Sub Sample1()
Dim i As Long, k As Long, endRow As Long
Dim c As Range, myRange As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")

Application.ScreenUpdating = False
wS2.Cells.Clear
wS1.Range("B1").Resize(, 6).Copy wS3.Range("B1")
wS3.Range("H1") = "合計"
For i = 2 To 14
wS3.Cells(i, "A") = 40 + (i - 2) * 5
Next i
Set myRange = wS3.Range("B2:H14")
wS1.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, unique:=True
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(2, "A"), wS1.Cells(endRow, "A")).Copy wS3.Range("A16")
wS1.ShowAllData
For i = 16 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS3.Range("B1") = wS3.Cells(i, "A")
With wS1.Range("A1")
.AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
.AutoFilter field:=2, Criteria1:=1
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow, "G")).Copy wS3.Range("I1")
For k = 2 To 14
Set c = wS3.Range("K:K").Find(what:=wS3.Cells(k, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
wS3.Cells(c.Row, "J").Resize(, 6).Copy wS3.Cells(k, "B")
Else
With wS3.Cells(k, "B")
.Value = 1
.Offset(, 1) = wS3.Cells(k, "A")
End With
End If
Next k
With wS3.Range("H2").Resize(13)
.Formula = "=SUM(D2:G2)"
.Value = .Value
End With