重複したデータ(空白は除く)のVBA表記について

いつもお世話になっております。

下記で質問した者です。
https://oshiete.goo.ne.jp/qa/13095593.html
質問カテゴリーをVBAに絞るため新たに質問させていただきました。

=SUMPRODUCT(1/COUNTIF(A1:A13,A1:A13&""))-1
上記の関数をVBAの構文で表すことは可能でしょうか？
重ねて関数にお詳しい方いらっしゃいましたらご教示の程よろしくお願いいたします。

No.5 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/08/16 11:58

＞VBA構文のWorksheet_Changeイベントをこちらの構文に組み込むことは可能でしょうか？

該当するシートモジュールに登録してください。
結果はH8セルに出力されます。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim dicT As Object
Dim maxrow As Long
Dim wrow As Long
If Target.Column <> 4 Then Exit Sub
Application.EnableEvents = False
Set dicT = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
maxrow = ws.Cells(Rows.Count, "D").End(xlUp).Row 'D列の最大行取得
For wrow = 10 To maxrow
If ws.Cells(wrow, "D").Value <> "" Then
dicT(ws.Cells(wrow, "D").Value) = True
End If
Next
ws.Cells(8, "H").Value = dicT.Count
Application.EnableEvents = True
End Sub

この回答へのお礼

tatsumaru77様、VBAの構築ありがとうございます。

私の認識間違いでselection changeの反映に修正し処理が行われました。
活用させていただきます。
この度はありがとうございました。

お礼日時：2022/08/16 13:50

No.4 回答者： tatsumaru77 回答日時： 2022/08/16 07:06

No2です。

以下のマクロを標準モジュールに登録してください。
D10セルから下方向の末尾までの重複無の件数をD9セルに表示します。

Option Explicit

Public Sub 件数カウント()
Dim ws As Worksheet
Dim dicT As Object
Dim maxrow As Long
Dim wrow As Long
Set dicT = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
maxrow = ws.Cells(Rows.Count, "D").End(xlUp).Row 'D列の最大行取得
For wrow = 10 To maxrow
If ws.Cells(wrow, "D").Value <> "" Then
dicT(ws.Cells(wrow, "D").Value) = True
End If
Next
ws.Cells(9, "D").Value = dicT.Count
End Sub

この回答へのお礼

tatsumaru77様、VBAの構築ありがとうございます。

問題なく反映できました。
因みにD9セルではなく離れた位置のH8セルに反映させたい場合は
ws.Cells(9, "D").Value = dicT.Count
こちらを修正する形でしょうか？

また色々と調べてる中でふと思いついたことがございまして、不躾なお願いで大変申し訳ございませんが、VBA構文のWorksheet_Changeイベントをこちらの構文に組み込むことは可能でしょうか？

重ねお願い申し上げます。

お礼日時：2022/08/16 11:39

No.3 回答者： fujillin 回答日時： 2022/08/15 21:58

No1です。

どのような使い方をなさりたいのか不明のままですが、ユーザー定義関数として作成してみました。
ご参考にでもなれば。

通常なら、1列（あるいは1行）での範囲で重複の削除を行うことが多いと思いますが、対象をセル範囲、あるいは複数セル範囲でも可能なようにしてあります。
算出方法は、No1の3番目のDictionaryを用いる方法で行っています。
（当方、365環境ではないため、UNIQUE関数が使えませんので・・）

使い方は通常の関数と同じで、
　=uniqueCount(A1:B10)
　=uniqueCount(A2:A10, C10:C20)
といった感じです。

事前に標準モジュールに以下をコピペしておきます。
Function uniqueCount(ParamArray r() As Variant) As Long
Dim dic, cv, c
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")

For i = LBound(r) To UBound(r)
If TypeName(r(i)) = "Range" Then
cv = r(i).Value
If Not IsArray(cv) Then cv = Array(cv)
For Each c In cv
If c <> "" Then
If Not dic.Exists(c) Then dic.add c, 1
End If
Next c
End If
Next i
uniqueCount = UBound(dic.keys) + 1
End Function

No.2 回答者： tatsumaru77 回答日時： 2022/08/15 15:18

補足要求です。

１．範囲は常にA1:A１3でしょうか。それとも、変わるものなのでしょうか。
２．算出した結果は、どのセルに表示するのでしょうか。

この回答へのお礼

tatsumaru77様、回答ありがとうございます。

範囲指定に重ね算出結果の回答ですが、理想はD10セルから下方向の末尾までをD9セルに表示させたいと思っております。
よろしくお願いいたします。

お礼日時：2022/08/15 20:10

No.1 回答者： fujillin 回答日時： 2022/08/15 15:10

こんにちは

VBAで行うにしてもエクセルの機能を利用する方が簡単です。

365環境ならUNIQUE関数が使えるので、
　WorksheetFunction.Unique(Range)
で得られた配列の数を数えれば良いでしょう。
https://excel-vba.work/2021/05/02/%E3%80%90vba%E …

Uniqueが使えないなら、作業列を利用して「重複を除く」のが簡単です
https://docs.microsoft.com/ja-jp/office/vba/api/ …

作業列などは用いずに行いたいのなら、Dictionaryを利用して順に登録し、最後にkeysの数を数えるのが一般的でしょうか。
https://docs.microsoft.com/ja-jp/office/vba/lang …

Dictionaryも使わないなら、一旦値を配列等に入れて、ループで重複の2個め以降を削除してから、残った値の数を数えるというプリミティブな方法でも可能と思います。

※ 最終形を、ユーザ定義関数になさりたいのか、プロシージャにしたいのかよくわからないので、方法論だけの回答です。