VBA 検索をかけ合計数とGrp番号を抽出

質問

現在、関数ではなく　VBAでマクロを勉強しているのですが、
下記のコードでエラーが発生してしまいます。
是非、ご教授願えませんでしょうか。

Sheet3を作業用のSheetとして使用しています。　
Sub Sample1()
Dim i As Long, k As Long, lastRow As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "B").End(xlUp).Row
.Range("B1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "B")
Range(.Cells(3, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (i - 1) * 2)
For k = wS2.Cells(Rows.Count, (i - 1) * 2).End(xlUp).Row To 2 Step -1
wS2.Cells(k, (i - 1) * 2 - 1) = WorksheetFunction.CountIfs(.Range("A:A"), wS3.Cells(i, "A"), _
.Range("C:C"), wS2.Cells(k, (i - 1) * 2))
For j = 2 To wS3.Cells(Rows.Count, "E").End(xlUp).Row
.Range("E1").AutoFilter field:=1, Criteria1:=wS3.Cells(j, "E")
Range(.Cells(3, "E"), .Cells(lastRow, "E")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (j - 1) * 2)
For l = wS2.Cells(Rows.Count, (j - 1) * 2).End(xlUp).Row To 2 Step -1
wS2.Cells(j, (j - 1) * 2 - 1) = WorksheetFunction.CountIfs(.Range("A:A"), wS3.Cells(j, "A"), _
.Range("E:E"), wS2.Cells(k, (j - 1) * 2))
If WorksheetFunction.CountIf(wS2.Columns((j - 1) * 2), wS2.Cells(k, (j - 1) * 2)) > 1 Then
wS2.Cells(l, (j - 1) * 2 - 1).Resize(, 2).Delete shift:=xlUp
End If
Next k
Next i
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

実際に抽出結果を出したい概要は下記に用になります。

検索したいsheet1には
セルBにはUsername番号などがあります。
　　　　　A　　　　　　　　B　　　　　　　C　　　　　D　　　　　E　　　　　F　　　　　G
１　　　　　　　　　　　Ｕｓｅｒｎａｍｅ　　　　　　Ｇｒｐ番号　　　
２　　　　　　　　　　　ｙａｍａｄａ１０ｘ　　　　　　Ｇｒｐ１　　　　　　　　　　　　
３　　　　　　　　　　　ｙａｍａｄａ４ｘ　　　　　　　Ｇｒｐ１　　　
４　　　　　　　　　　　ｙａｍａｄａ１０ｘ　　　　　　Ｇｒｐ１
５　　　　　　　　　　　ｙａｍａｄａ１０ｘ　　　　　　Ｇｒｐ１
６　　　　　　　　　　　ｙａｍａｄａ４ｘ　　　　　　　Ｇｒｐ２
７　　　　　　　　　　　ｙａｍａｄａ１０ｘ　　　　　　Ｇｒｐ２
８　　　　　　　　　　　ｙａｍａｄａ４ｘ　　　　　　　Ｇｒｐ２
９　　　　　　　　　　　ｙａｍａｄａ１０ｘ　　　　　　Ｇｒｐ３
．
．
５０　　　　　　　　　　　ｙａｍａｄａ４ｘ　　　　　　Gｒｐ４０

Sheet2にはセルBとCにyamada10xの合計数とgrp番号、セルEとFにはyamada4xの合計数とgrp番号などがあります。
　　　　　A　　　　　　　　B　　　　　　　　　　C　　　　　　　D　　　　　　　　E　　　　　　　　　　　F　　　　　
１
２　　　　　　　ｙａｍａｄａ１０ｘの合計数　Ｇｒｐ番号　　　　　　　ｙａｍａｄａ４ｘの合計数　　Ｇｒｐ番号　　
３　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
４　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
５　　　　　　　　　　　　　　
．
．
１０　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　

sheet1で検索したユーザ名・Grp番号などを行数3のセルC・ＦにはGrp番号を抽出
行数3のセルB・ＥにはGrp番号ごとのｙａｍａｄａ１０ｘとｙａｍａｄａ４ｘの合計数をsheet2に
抽出させたいという形になります。
　　　　　　A　　　　　　　　B　　　　　　　　　　C　　　　　　　D　　　　　　　　E　　　　　　　　　　F　　　　　
１
２　　　　　　　ｙａｍａｄａ１０ｘの合計数　　Ｇｒｐ番号　　　　　　　ｙａｍａｄａ４ｘの合計数　Ｇｒｐ番号　　
３　　　　　　　　　　　　　　　３　　　　　　　　　Ｇｒｐ１　　　　　　　　　　　 １　　　　　　　　Ｇｒｐ１
４　　　　　　　　　　　　　　　１　　　　　　　　　Ｇｒｐ２　　　　　　　　　　　 ２　　　　　　　　Ｇｒｐ２
５　　　　　　　　　　　　　　　１　　　　　　　　　Ｇｒｐ３
．
．
１０　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　１　　　　　　　Ｇｒｐ４０

わかりにくい図と説明で申し訳ございません。
お手数をおかけしますが、ご教授の方をお願いできますでしょうか。
よろしくお願い致します。

回答No.3

tom04 · ベストアンサー

No.1です。

結局、行・列合わせだけの問題だと思います。
質問ではSheet1のB列は2種類だけですが、何種類あっても対応できるようにしてみました。
Sheet2の他の列に数式などが入っていてはいけませんので、
D:E列・I：J列・N:O列・・・と5列おきに操作しています。

Sub Sample3()
Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
If wS2.Range("A1") = "" Then
wS2.Range("A1") = "ダミー"
End If
lastRow = wS2.UsedRange.Rows.Count
lastCol = wS2.Cells(10, Columns.Count).End(xlToLeft).Column
If lastRow > 9 Then
For j = 4 To lastCol Step 5
Range(wS2.Cells(10, j), wS2.Cells(lastRow, j + 1)).ClearContents
Next j
End If
With Worksheets("Sheet1")
If .Range("A4") = "" Then
.Range("A4") = "ダミー"
End If
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(4, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(10, (i - 2) * 5 + 4) = .Range("F4")
wS2.Cells(10, (i - 2) * 5 + 5) = wS3.Cells(i, "A")
wS2.Cells(10, (i - 2) * 5 + 5).NumberFormatLocal = "@の合計数"
.Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(5, "F"), .Cells(lastRow, "F")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(11, (i - 2) * 5 + 4)
For k = wS2.Cells(Rows.Count, (i - 2) * 5 + 4).End(xlUp).Row To 11 Step -1
wS2.Cells(k, (i - 2) * 5 + 5) = WorksheetFunction.CountIfs(.Range("F:F"), wS2.Cells(k, (i - 2) * 5 + 4), .Range("B:B"), _
wS2.Cells(10, (i - 2) * 5 + 5))
If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 5 + 4), wS2.Cells(k, (i - 2) * 5 + 4)) > 1 Then
wS2.Cells(k, (i - 2) * 5 + 4).Resize(, 2).Delete shift:=xlUp
End If
Next k
Next i
wS2.Columns.AutoFit
wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole
wS3.Cells.Clear
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

今度はどうでしょうか？m(_ _)m

お礼

回答ありがとうごいました。
何度もお答えしてもらい申し訳ありません。
VBAの方でマクロ組むことができました。
是非、参考にしていきたいと思います

回答No.2

30246kiku

以下でどうでしょう。
Sheet1が選ばれている状態で実行すると、新シートに表示されます。

提示された記述ほど難しい事はしていないので、コメントなくても・・・

Public Sub Samp1()
　　Dim dic As Object
　　Dim sS As String
　　Dim vS As Variant, v As Variant
　　Dim B As Long, D As Long
　　Dim i As Long, j As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　B = Range("B1").Column
　　D = Range("D1").Column
　　For i = 2 To Cells(Rows.Count, B).End(xlUp).Row
　　　　sS = Cells(i, B).Value
　　　　If (Not dic.Exists(sS)) Then
　　　　　　dic.Add sS, CreateObject("Scripting.Dictionary")
　　　　End If
　　　　v = Cells(i, D).Value
　　　　dic(sS)(v) = dic(sS)(v) + 1
　　Next

　　Worksheets.Add After:=ActiveSheet
　　i = 0
　　For Each vS In dic.Keys
　　　　With Range("B2").Offset(, i)
　　　　　　.Resize(, 2).Value = Array(vS & "の合計数", "Grp番号")
　　　　　　j = 1
　　　　　　For Each v In dic(vS).Keys
　　　　　　　　.Offset(j).Resize(, 2).Value = Array(dic(vS)(v), v)
　　　　　　　　j = j + 1
　　　　　　Next
　　　　　　With .Resize(j, 2)
　　　　　　　　.Sort .Cells(2), xlAscending, Header:=xlYes
　　　　　　End With
　　　　End With
　　　　i = i + 3
　　Next
　　With Cells
　　　　.HorizontalAlignment = xlCenter
　　　　.EntireColumn.AutoFit
　　End With
　　Set dic = Nothing
End Sub

お礼

お礼送れて申し訳ございません
回答ありがとうございます。
参考にさせて頂きたいと思います

回答No.1

tom04

こんにちは！

http://okwave.jp/qa/q8773631.html
と同じ内容ですね？

COUNTIFS関数で解決済みだったみたいですが・・・
今度はVBAで！というコトのようですので、

VBAの場合、1行・1列違ってもエラーになったり、
動いたとしてもデタラメな結果になってしまいます。

前回の場合はSheet1のA・B列のデータでしたので、おそらくこのコードで大丈夫だったはずですが、
今回は前回のA列がB列に　B列がD列に移動しているようなので
コード内容を変更しなければなりません。
前回のコードに手を加えてみました。Sheet1は1行目が項目行で、データは2行目以降にあるとします。
標準モジュールです。

Sub Sample2()
Dim i As Long, k As Long, lastRow As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
lastRow = wS2.UsedRange.Rows.Count
'★Sheet2の3行目からの表示なので、一旦2行目以降を消去
If lastRow > 1 Then
wS2.Rows(2 & ":" & lastRow).Clear
End If
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row '★
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") '★
wS2.Cells(2, (i - 1) * 3 - 1) = wS3.Cells(i, "A") & "の合計数" '★
wS2.Cells(2, (i - 1) * 3) = "Ｇｒｐ番号" '★
Range(.Cells(2, "D"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (i - 1) * 3) '★
For k = wS2.Cells(Rows.Count, (i - 1) * 3).End(xlUp).Row To 3 Step -1 '★
wS2.Cells(k, (i - 1) * 3 - 1) = WorksheetFunction.CountIfs(.Range("B:B"), wS3.Cells(i, "A"), _
.Range("D:D"), wS2.Cells(k, (i - 1) * 3)) '★
If WorksheetFunction.CountIf(wS2.Columns((i - 1) * 3), wS2.Cells(k, (i - 1) * 3)) > 1 Then '★
wS2.Cells(k, (i - 1) * 3 - 1).Resize(, 2).Delete shift:=xlUp '★
End If
Next k
Next i
wS2.Columns.AutoFit
wS3.Cells.Clear
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

※　コード内の「★」の部分に手を加えています（列合わせのため）
※　元データがB・D列でない場合はとんでもない表示になります。m(_ _)m

補足

何度もの質問に答えて頂きありがとうございます。
Sub Sample2()
コードの方を使いましたら問題なく
実行の方ができました。

補足という事ですが、失礼とは存知ますがもう一度質問の方を
させていただいてもよろしいでしょうか？

Sheet1の検索したいUsername・Grp番号のセルが違う場所にある場合、
Sheet2の検索結果も出したいセルの位置を各違うセルの位置に出したいという場合になります。

検索したいSheet1では、行数5(セルB)にはUsername
行数5(セルF)にGrp番号という形です。
　　　　　A　　　　　B　　　　　C　　　　　D　　　　　E　　　　　F　　　　　G
１
２
３
４　　　　　　　　Username　　　　　　　　　　　　　　　　　　Grp番号　　　
５　　　　　　　　yamada10x　　　　　　　　　　　　　　　　　　Grp1　　　
６　　　　　　　　 yamada4x　　　　　　　　　　　　　　　　　　Grp1　
７　　　　　　　　yamada10x　　　　　　　　　　　　　　　　　　Grp1　
８　　　　　　　　yamada10x　　　　　　　　　　　　　　　　　　Grp2　
８　　　　　　　　yamada10x　　　　　　　　　　　　　　　　　　Grp2
.
５０　　　　　　　　yamada4x　　　　　　　　　　　　　　　　　　Grp40　
sheet1で検索したユーザ名・Grp番号などを行数10のセルD・IにはGrp番号を抽出
行数3のセルE・JにはGrp番号ごとのｙａｍａｄａ１０ｘとｙａｍａｄａ４ｘの合計数をsheet2に
抽出、Grp番号と合計数のセルの位置を逆にyamada10xとyamada4xの合計数をセルD.EとI.Jと遠い
セルの位置にずらしたいという形です。
　　　　　　D　　　　　　E　　　　　　　　　F　　　　　G　　　　　H　　　　　I　　　　　J
１０　　Grp番号　yamada10xの合計数　　　　　　　　　　　　　　　Grp番号　　yamada4xの合計数
１１　　　Grp1　　　　　2　　　　　　　　　　　　　　　　　　　　　　　　　Grp1　　　　　1
１２　　　Grp2　　　　　1　　　　　　　　　　　　　　　　　　　　　　　　　Grp2　　　　　1
１３　　　Grp3　　　　　1　　　　　　　　　　　　　　　　　　　　　　　　　Grp3　　　　　1
１４　　　Grp4　　　　　2　　　　　　　　　　　　　　　　　　　　　　　　　Grp4　　　　　1
・　
・　
２０　　　grp10　　　　 1

何度もを質問して申し訳ございませんが、
ご教授の方お願いしてもよろしいでしょうか？