-PR-
  • 困ってます
  • 質問No.8778309
解決
済み

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

  • 閲覧数96
  • ありがとう数10
  • 気になる数0
  • 回答数3
  • コメント数0

お礼率 33% (2/6)

現在、関数ではなく 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
1           Username      Grp番号   
2           yamada10x      Grp1            
3           yamada4x       Grp1   
4           yamada10x      Grp1
5           yamada10x      Grp1
6           yamada4x       Grp2
7           yamada10x      Grp2
8           yamada4x       Grp2
9           yamada10x      Grp3


50           yamada4x      Grp40

Sheet2にはセルBとCにyamada10xの合計数とgrp番号、セルEとFにはyamada4xの合計数とgrp番号などがあります。
     A        B          C       D        E           F     

2       yamada10xの合計数 Grp番号       yamada4xの合計数  Grp番号  
3                                  
4                                 
5              


10                                         

sheet1で検索したユーザ名・Grp番号などを行数3のセルC・FにはGrp番号を抽出
行数3のセルB・EにはGrp番号ごとのyamada10xとyamada4xの合計数をsheet2に
抽出させたいという形になります。
      A        B          C       D        E          F     

2       yamada10xの合計数  Grp番号       yamada4xの合計数 Grp番号  
3               3         Grp1            1        Grp1
4               1         Grp2            2        Grp2
5               1         Grp3


10                                         1       Grp40


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

質問者が選んだベストアンサー

  • 回答No.3
レベル14

ベストアンサー率 49% (2537/5118)

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
お礼コメント
khnggtu11

お礼率 33% (2/6)

回答ありがとうごいました。
何度もお答えしてもらい申し訳ありません。
VBAの方でマクロ組むことができました。
是非、参考にしていきたいと思います
投稿日時 - 2014-10-07 06:22:15
-PR-
-PR-

その他の回答 (全2件)

  • 回答No.1
レベル14

ベストアンサー率 49% (2537/5118)

こんにちは! http://oshiete.goo.ne.jp/qa/8773631.html と同じ内容ですね? COUNTIFS関数で解決済みだったみたいですが・・・ 今度はVBAで!というコトのようですので、 VBAの場合、1行・1列違ってもエラーになったり、 動いたとしてもデタラメな結果になってしまいます。 前回の場合はSheet1のA・B列のデータでしたので、おそらくこのコードで大丈夫だ ...続きを読む
こんにちは!

http://oshiete.goo.ne.jp/qa/8773631.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) = "Grp番号" '★
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
補足コメント
khnggtu11

お礼率 33% (2/6)

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

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

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

検索したいSheet1では、行数5(セルB)にはUsername
行数5(セルF)にGrp番号という形です。
     A     B     C     D     E     F     G



4        Username                  Grp番号   
5        yamada10x                  Grp1   
6         yamada4x                  Grp1 
7        yamada10x                  Grp1 
8        yamada10x                  Grp2 
8        yamada10x                  Grp2
.
50        yamada4x                  Grp40 
sheet1で検索したユーザ名・Grp番号などを行数10のセルD・IにはGrp番号を抽出
行数3のセルE・JにはGrp番号ごとのyamada10xとyamada4xの合計数をsheet2に
抽出、Grp番号と合計数のセルの位置を逆にyamada10xとyamada4xの合計数をセルD.EとI.Jと遠い
セルの位置にずらしたいという形です。
      D      E         F     G     H     I     J
10  Grp番号 yamada10xの合計数               Grp番号  yamada4xの合計数
11   Grp1     2                         Grp1     1
12   Grp2     1                         Grp2     1
13   Grp3     1                         Grp3     1
14   Grp4     2                         Grp4     1
・ 
・ 
20   grp10     1

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

                         
投稿日時 - 2014-10-06 06:42:01
  • 回答No.2
レベル12

ベストアンサー率 73% (370/503)

以下でどうでしょう。 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    ...続きを読む
以下でどうでしょう。
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
お礼コメント
khnggtu11

お礼率 33% (2/6)

お礼送れて申し訳ございません
回答ありがとうございます。
参考にさせて頂きたいと思います
投稿日時 - 2014-10-06 06:43:56
  • 回答数3
このQ&Aで解決しましたか?
関連するQ&A
-PR-
-PR-
こんな書き方もあるよ!この情報は知ってる?あなたの知識を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する
-PR-
-PR-
-PR-

特集


関連するQ&A

-PR-

ピックアップ

-PR-
ページ先頭へ