ExcelVBAでの検索結果抽出方法

ExcelVBAで教えて下さい。

A | B | C | D | E |F|
地域コード| 性別コード|年代|野球|サッカー|テニス|
201| 1 | 40 | 5 | - | 1|
201| 2 | 55 | 6 | 1 | 3|

というような表が1万行近くあります。
これを「地域別の表」にして、なおかつ「男女別」「スポーツ別」にして、人数を表にしたいと思っています。

表のイメージはこんな感じです。

ーー| 201 | 野球|サッカー|テニス|
男性| 40 | 5 | - | 1 |
…
女性| 55 | 6 | 1 | 3 |

年代は40、45と5才刻みで100歳までで、男女は1と2のコードで表します。

クロスのところにはいっているのは人数です。

Sheet1が元データなので、Sheet2に表を作りたいです。表はどうにか作れるので、

・地域コード
・性別コード
・スポーツ

に、一致した場合に別シートにコピーできるコードを教えていただけるとありがたいです。

Sheet1の元データの年代は、地域によっては、該当なしだと無い年代もあります。

今回は投稿のためわかりやすければ…と思い、空白セルにハイフンを入れましたが実際は入っていません。

ややこしくて申し訳ありませんが助けていただきたく、お願い致します。

No.1 回答者： hirorinmattsu 回答日時： 2014/01/08 22:24

VBAでということなのですが、VBAで作ったユーザー定義関数によって解決してはと考えます。

データベースのシートは変更することなく行うようにと考えたとき、既存のVlookUP関数では重複したデータ（2件目以降）を拾い上げられません。累積して検索拾い上げを行う方法を書いておきます。
(1)まず、検索にかけたものがデータベース上のどこに、何件あるのかを知る必要があります。この際、ヒットした位置を一度カンマ区切りのデータとして単一セルに書き出しておくことをお勧めします。これ以外の方法でもユーザー定義関数で作ってはありますが、件数がかさむと処理が重くなるので上記の方法で書き出したほうがいいとおもいます。

----該当するデータの位置をカンマ区切りで書き出すユーザー定義関数AcuMatch----下記をVBAのモジュールにコピペして使ってください。

Function AcuMatch(条件 As Variant, 検索範囲 As Range) As Variant
Application.Volatile
Dim tmpans As Integer 'CountIf関数によって一つずつ検索し、存在すれば 1,しなければ 0
Dim SR As Integer '始まりの行番地
Dim ER As Integer '終わりの行番地
Dim SC As Integer '始まりの列番地
Dim EC As Integer '終わりの列番地
Dim i As Integer 'カウンタ
Dim tmpmemo As Variant
Dim Acutemp As String
'検索範囲のシート名、ブック名を格納
S = 検索範囲.Parent.Name
w = 検索範囲.Parent.Parent.Name
'初期化
tmpans = 0
SR = 0
Coun = 1
tmpmemo = ""
Acutemp = ""
'範囲のR1C1化
SR = 検索範囲.Row
SC = 検索範囲.Column
ER = 検索範囲.Row + 検索範囲.Rows.Count - 1
EC = 検索範囲.Column + 検索範囲.Columns.Count - 1
'処理
If SR = ER Then '行が1の場合(水平方向に検索）
For i = SC To EC Step 1
tmpans = WorksheetFunction.CountIf(Workbooks(w).Sheets(S).Cells(SR, i), 条件)
If tmpans = 1 Then
tmpmemo = i - SC + 1
Strtemp = Mid(Str(tmpmemo), 2, 10)
Acutemp = Acutemp & "," & Strtemp
'Coun = Coun + 1
End If
Next i
mojisuu = Len(Acutemp)
AcuMatch = Mid(Acutemp, 2, mojisuu)
Else 'レコード検索（垂直方向に検索）
For i = SR To ER Step 1
tmpans = WorksheetFunction.CountIf(Workbooks(w).Sheets(S).Cells(i, SC), 条件)
If tmpans = 1 Then
tmpmemo = i - SR + 1
Strtemp = Mid(Str(tmpmemo), 2, 10)
Acutemp = Acutemp & "," & Strtemp
'Coun = Coun + 1
End If
Next i
mojisuu = Len(Acutemp)
AcuMatch = Mid(Acutemp, 2, mojisuu)
End If
End Function

(2)書き出された検索位置を表すカンマ区切りデータを元にして拾い上げる。

----カンマ区切りテキストから配列として読み込み検索するユーザー定義関数CSVVLookup----

Function CSVVLookUP(banme As Double, strArray As String, 対象範囲 As Range, Optional 対象列 As Integer = 1, Optional エラー除去 As Boolean = True) As VariantDim tmp As Variant
tmp = Split(strArray, ",")

Dim part As Variant
Dim result() As Single

ReDim result(UBound(tmp))

Dim cnt As Integer
cnt = 0

For Each part In tmp
result(cnt) = Val(part)
cnt = cnt + 1
Next
If エラー除去 = True And cnt < banme Then
CSVVLookUP = ""
Else
CSVVLookUP = WorksheetFunction.Index(対象範囲, WorksheetFunction.Index(result, banme), 対象列)
End If

End Function


この二つの関数を使ってやってみてはと思います。
詳しくは http://hirorinmattsu.com/

参考URL：http://hirorinmattsu.com/

No.2 ベストアンサー 回答者： tom04 回答日時： 2014/01/09 21:27

こんばんは！

一例です。

↓の画像で左側がSheet1で右側がSheet2とします。
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は全く使用していない状態にしておいてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, cnt As Long, endRow As Long, 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.ClearContents
wS1.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS3.Range("A:A").Sort key1:=wS3.Range("A1"), order1:=xlAscending, Header:=xlYes
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS1.Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS1.Range("B:F").Copy wS3.Range("B1")
endRow = wS3.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS3.Cells(1, "B"), wS3.Cells(endRow, "F")).Sort key1:=wS3.Range("B1"), order1:=xlAscending, Header:=xlYes, _
key2:=wS3.Range("C1"), order1:=xlAscending, Header:=xlYes
wS3.Range("B1") = wS3.Cells(i, "A")
endRow = wS3.Cells(Rows.Count, "B").End(xlUp).Row
If wS2.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
cnt = wS2.Cells(Rows.Count, "A").End(xlUp).Row + 1
Else
cnt = 1
End If
Range(wS3.Cells(1, "B"), wS3.Cells(endRow, "F")).Copy wS2.Cells(cnt, "A")
Next i
With wS2.Range("A:A")
.Replace what:=1, replacement:="男性", lookat:=xlWhole
.Replace what:=2, replacement:="女性", lookat:=xlWhole
End With
wS1.AutoFilterMode = False
wS3.Cells.Clear
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

理想に近い形ができました！ありがとうございました！

お礼日時：2014/01/14 11:06