- ベストアンサー
VBA 検索結果を抽出するマクロ
- VBAを使用して、Sheet1から検索結果を抽出するマクロのコードです。セルBにはユーザ名、セルCにはGrp番号が入っています。抽出結果はSheet2のセルBとCにyamada10xの合計数とGrp番号、セルEとFにはyamada4xの合計数とGrp番号が表示されます。
- セルBにはユーザ名、セルCにはGrp番号が入っており、Sheet1から検索結果を抽出したいと思っています。抽出結果はSheet2のセルBとCにyamada10xの合計数とGrp番号、セルEとFにはyamada4xの合計数とGrp番号が表示されます。
- VBAでマクロを作成してSheet1から検索結果を抽出したいと思っています。セルBにはユーザ名、セルCにはGrp番号が入っており、Sheet2のセルBとCにyamada10xの合計数とGrp番号、セルEとFにはyamada4xの合計数とGrp番号を表示したいです。
- khnggtu11
- お礼率33% (2/6)
- Visual Basic
- 回答数3
- ありがとう数10
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
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
その他の回答 (2)
- 30246kiku
- ベストアンサー率73% (370/504)
以下でどうでしょう。 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
お礼
お礼送れて申し訳ございません 回答ありがとうございます。 参考にさせて頂きたいと思います
- tom04
- ベストアンサー率49% (2537/5117)
こんにちは！ 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 何度もを質問して申し訳ございませんが、 ご教授の方お願いしてもよろしいでしょうか？
お礼
回答ありがとうごいました。 何度もお答えしてもらい申し訳ありません。 VBAの方でマクロ組むことができました。 是非、参考にしていきたいと思います