VBA フィルター後に重複を1件としてカウントした

質問

VBA初心者です。
Sheet1にリスト、Sheet2にボタンなどを配置し、Sheet1のリストにフィルターをして、その結果の中の重複分を1件としてカウントして、合計で何件あるのかというものを作りたいと思っています。

Sub　計算（）
Worksheets("sheet1").Range("A1").AutoFilter Field:=10,Criteria1:=Worksheets("sheet2").Range("C3").Value
Count = WorksheetFunction.Subtotal(3,Range("j2：j577"))
n = WorksheetFunction.Subtotal(3,Range("j2:j577"))
Application.Evaluate("=SUMPRODUCT(1/COUNTIF(C1：C577,C1:C577))") Worksheets("sheet2").Range("E3").Value = n & "件"
Worksheets("sheet2").Select
End　Sub

というような感じで作ってみましたが、重複を1件として数えず全件の件数が出てしまいます。

初心者なのでいろいろ不備はあるかと思いますが、どのように直せばよろしいか、どうか教えていただけますようよろしくおねがいいたします。

回答No.3

HohoPapa · ベストアンサー

>できれば文字列で教えていただけるとたいへん助かります。

以下です。

Sub RecCounter()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim MyCnt As Long
　Dim MyKey As String

　'検索キーを取得
　With ThisWorkbook.Sheets("Sheet2")
　　MyKey = .Cells(3, 3).Value
　End With

　'SQL全文を組み立て、実行
　SQL = "SELECT count(列名3) as RecCnt" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where 列名10 = " & "'" & MyKey & "'" & vbCrLf
　SQL = SQL & "GROUP BY 列名3" & vbCrLf

　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　'レコード数を数える
　MyCnt = 0
　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　Do
　　　If rs.EOF = True Then Exit Do
　　　MyCnt = MyCnt + 1
　　　rs.MoveNext
　　Loop
　End If

　'数えたレコード数を出力
　With ThisWorkbook.Sheets("Sheet2")
　　.Cells(3, 5).Value = MyCnt & "件"
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

お礼

お言葉に甘えてしまいましたが、大変勉強になりました。
がんばってやってみますね。
本当にありがとうございました！

回答No.2

HohoPapa

添付画像のように、J列の値たちが数値なら
後記のコードはいかがでしょうか。
SQLの知識も必要なので若干ハードルが上がりますが
身に着ければ大きな武器になるはずです。

もし、J列の値たちが文字列なら指摘してください。
コードを修正してポストします。

ご自身で作ったコードをポストして質問するのはとってもいいことと思いますが
合わせて、サンプルシートと具体的にどのような集計をしたいのかを
説明するとよりコメントが得やすいと思います。

Sub RecCounter()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim MyCnt As Long
　Dim MyKey As Long

　'検索キーを取得
　With ThisWorkbook.Sheets("Sheet2")
　　MyKey = .Cells(3, 3).Value
　End With

　'SQL全文を組み立て、実行
　SQL = "SELECT count(列名3) as RecCnt" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where 列名10 = " & MyKey & vbCrLf
　SQL = SQL & "GROUP BY 列名3" & vbCrLf

　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　'レコード数を数える
　MyCnt = 0
　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　Do
　　　If rs.EOF = True Then Exit Do
　　　MyCnt = MyCnt + 1
　　　rs.MoveNext
　　Loop
　End If

　'数えたレコード数を出力
　With ThisWorkbook.Sheets("Sheet2")
　　.Cells(3, 5).Value = MyCnt & "件"
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

お礼

丁寧にありがとうございます。
なんかやりたいことにぐっと近づいた気がします。
できれば文字列で教えていただけるとたいへん助かります。
サンプル画像つければいいんですね。
慌てていて思いつかなかったです（泣）
でも、貼り付けていただいたものみたいな感じです。

回答No.1

imogasi

例データ
A1:A10
データ　特徴=文字列　数値だと後半のSUBTOTALの引数が変わる。
a
s
d
a
s
f
g
a
a
ーー
標準モジュールに
Sub test01()
ActiveSheet.Range(Cells(1, 1), Cells(10, 1)).AdvancedFilter _
Action:=xlFilterInPlace, Unique:=True
End Sub
を実行。
ーー
結果　見てくれのままー＞行はとびとびになっている
データ
a
s
d
f
g
ーー
同じく標準モジュールに
Sub test02()
x = Application.WorksheetFunction.Subtotal(103, Range("A2:A10"))
MsgBox x
End Sub
で５が返る。Xはセルの値に代入するとか、お好みで。
VBAの中だが、関数を使うのがコード行数が少なくなるので、使った。
ーー
関数でのやり方もふくめ
参考
https://office-hack.com/excel/duplicate-data/
https://vbabeginner.net/check-number-excluding-duplicates/
ーー
VBAでも
同じ値は１つとカウントしたい場合
配列を２つ使った二重ループの方法
Dictionaryを使う方法
COUNTIF関数での方法
などある。
初心者のVBAの勉強項目としては、特殊な個所。
もっとほかに大切で、勉強することが多くある、と思う。

お礼

教えていただきありがとうございました。
どうしても必要だったのでやってみた次第ですが、私にはまだ早いということなのですね。
いろいろ他を勉強してからまたチャレンジしてみます。