この関数と同じ処理をVBAで行うにはどうしたら良いでしょうか？ これは、1列の中に同じ値が複数存在し

この関数と同じ処理をVBAで行うにはどうしたら良いでしょうか？
これは、1列の中に同じ値が複数存在しているかユニークかを判断させる処理です。
AM列中の結果をAO列に書き出してます。
=IF(COUNTIF($AM$1:AM1,$AM1)>=2,"重複","ユニーク")

数十万行あるので関数だと非常に時間がかかるため、
VBAで処理してみたいと思っています。

本当は、AM列以外にAQ列、AU列でも同様の処理を行えると嬉しいです。

No.23 回答者： KenKen_SP 回答日時： 2022/07/11 18:48

こんにちは。

試しにAccessですが。

テーブル　myTable
　フィールド　ID (主キー、並び維持用の通し番号）
　フィールド　myItem（短い文字列型、重複ありインデックス）

で6文字ぐらい、17万件くらい重複するサンプルデータを30万件生成（VBAで）
空のクエリを作成し、SQLビューで次を貼付け。

SELECT myTable.ID, myTable.myItem, subQuery.Dup_count
FROM myTable
LEFT JOIN (
　　SELECT myItem, COUNT(myItem) AS Dup_count
　　FROM myTable
　　GROUP BY myItem
　　HAVING (COUNT(myItem) > 1)
) AS subQuery
ON myTable.myItem = subQuery.myItem
ORDER BY myTable.ID

だと、大体３秒くらい。
あとはDup_count > 1 のとき「重複あり」と表示するだけなので、４秒くらいになりそうですね。
大きなデータはやはり ACCESS が有利です。検討してみて下さい。

自分ならデータベース上で処理させて、結果のみ EXCEL 側で受け取る仕様にする気がほんのりします。

この回答へのお礼

ありがとうございます。
作業用PCにAccessを導入しなければいけないという障壁があるんです。
今のところNo.14の方法がベストと思って実作業に取り掛かってます。

お礼日時：2022/07/11 18:57

No.22 回答者： googoo900 回答日時： 2022/07/11 03:11

こういう処理はエクセルの機能を使うのが速いだろうということで、下記のエクセルの機能をマクロで自動化したものになります。

・データを昇順に並べ替え
・関数を使った上下のデータとの比較による重複チェック
・データを並べ替えで元の並び順に戻す
このページだけをみて作成したのですが、アイデアは2ページ目(早い段階の回答)で出ていたようですね。こういうやり方もあるということで、回答しておきます。

データ開始列と繰り返し数を指定できるようにしています。必要に応じて下記の2項目(コードの10～11行目)の値を修正ください。
また、繰り返し数を2以上にした場合は、開始列から3列おきにチェックを繰り返します。
data_row0 = 39 '***　重複チェックするデータ開始列（AM列=39）
rep_num = 1 '***　繰り返し回数

ちなみに自分の環境では1列30万行のデータで7秒台でした。14年前のパソコン(Core2 Duo P8600)ということを考慮すると、新しい(というか普通の)パソコンならいいタイムを出せる可能性があります。


Sub 重複判定1()
Dim endrow As Single
Dim data_row As Single
Dim rep_num As Single
Dim start_time As Double
Dim fin_time As Double
Application.ScreenUpdating = False
'所要時間測定用
start_time = Timer
data_row0 = 39 '***　重複チェックするデータ開始列（AM列=39）
rep_num = 1 '***　繰り返し回数　というかチェックする列数

'ここからメイン
data_row = data_row0

Do Until (data_row - data_row0) / 3 = rep_num

endrow = Cells(Rows.Count, data_row).End(xlUp).Row
'処理のための列を挿入(後で削除)
Columns(data_row + 1).Insert
'データを名前順に並べ替え
Cells(1, data_row + 1) = 1
Cells(2, data_row + 1) = 2
Range(Cells(1, data_row + 1), Cells(2, data_row + 1)).AutoFill Destination:=Range(Cells(1, data_row + 1), Cells(endrow, data_row + 1))
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add key:=Cells(1, data_row), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(Cells(1, data_row), Cells(endrow, data_row + 1))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'ダブりチェックの数式をセルに貼り付け
Cells(1, data_row + 3) = "=IF(r[0]c" & data_row & "=r[1]c" & data_row & "," & Chr(34) & "重複" & Chr(34) & "," & Chr(34) & "ユニーク" & Chr(34) & ")"
Cells(2, data_row + 3) = "=IF(OR(r[0]c" & data_row & "=r[-1]c" & data_row & ",r[0]c" & data_row & "=r[1]c" & data_row & ")," & Chr(34) & "重複" & Chr(34) & "," & Chr(34) & "ユニーク" & Chr(34) & ")"
Cells(2, data_row + 3).Copy Range(Cells(2, data_row + 3), Cells(endrow, data_row + 3))
Range(Cells(1, data_row + 3), Cells(endrow, data_row + 3)).Copy
Range(Cells(1, data_row + 3), Cells(endrow, data_row + 3)).PasteSpecial xlPasteValues '値で上書きする

'並び順を元に戻す
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add key:=Cells(1, data_row + 1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(Cells(1, data_row), Cells(endrow, data_row + 3))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'処理用に追加した列を削除
Range(Cells(1, data_row + 1), Cells(endrow, data_row + 1)).Delete

data_row = data_row + 3
Loop

Application.ScreenUpdating = True

'所要時間測定用
fin_time = Timer
MsgBox _
Int((Timer - start_time) / 3600) & "時間" & _
Int((Timer - start_time) / 60) Mod 60 & "分" & _
Int(Timer - start_time) Mod 60 & "秒" & _
Int(100 * ((Timer - start_time) - Int(Timer - start_time)))

End Sub

No.21 回答者： ひろみch 回答日時： 2022/07/09 01:53

VBAの回答は出てるので・・・・

私からは、条件付き書式の重複チェックは試されました？

この回答へのお礼

条件付き書式での方法は、今回の要件を満たせなさそうでした。
ありがとうございました。

お礼日時：2022/07/11 18:42

No.20 回答者： fandp 回答日時： 2022/07/08 23:31

ACCESS使わないですか。

No.19 回答者： めぐみん_ 回答日時： 2022/07/08 15:18

No.18です。

Microsoft.ACE.OLEDB.12.0

で１列３０万行やってみましたが、8.2秒かかりました。
やっぱ遅しですね。

この回答へのお礼

これは、関数ではなくデータベースを使って試されたという事ですね？
色々試して頂いて本当に感謝します。

ちなみに当方の30万行リストは重複チェック列が3列あり、
No.14のソースで一括テストしたところ31秒かかりました。
しかしCountif関数では1列だけで30分待っても返ってこず強制終了させてたので涙が出る思いです。
実はもう一つ、80万行超えのリストもあり、ワクワクしております。

お礼日時：2022/07/08 17:10

No.18 回答者： めぐみん_ 回答日時： 2022/07/08 09:49

No.11です。

少数のデータのみで検証し回答してきましたが、どうもCOUNTIFの範囲に３０万行は多いみたい？
それっぽいエラーが出ますので、私の方はスル～してください。
どうも他に回答が付いている感じですし、ここで自Ｂｏｏｋへの接続はいらなさそうなので。

No.17 回答者： shinkibasu1 回答日時： 2022/07/08 09:35

プログラミングは、それで大丈夫ですので進めて下さい。

No.14 回答者： tatsumaru77 回答日時： 2022/07/07 21:16

No13です。

補足ありがとうございました。
シート名はSheet1にしてあります。あなたの環境にあわせて設定してください。
AK列の結果をAM列へ
AN列の結果をAP列へ設定しています。
データ３０万件で当方の環境で１２秒かかりました。（１列で６秒）
判定列を増やす場合は、 Call set_column(ws, "AK", "AM")
の箇所を追加／変更してください。
---------------------------------------------------
Option Explicit
Public Sub 重複判定()
Dim ws As Worksheet
Dim wrow As Long
Dim key As Variant
Dim t1 As Variant
Dim t2 As Variant
Dim arr
Set ws = Worksheets("Sheet1")
Application.ScreenUpdating = False
t1 = Time
Call set_column(ws, "AK", "AM")
Call set_column(ws, "AN", "AP")
t2 = Time
MsgBox ("完了=" & Second(t2 - t1))

End Sub
'指定カラムの重複判定
Private Sub set_column(ByVal ws As Worksheet, ByVal col1 As String, ByVal col2 As String)
Dim maxrow As Long
Dim dicT As Object
Dim arr1 As Variant
Dim arr2 As Variant
Dim wrow As Long
Dim key As String
maxrow = ws.Cells(Rows.Count, col1).End(xlUp).Row '最大行取得
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
ReDim arr2(1 To maxrow)
arr1 = ws.Range(col1 & "1:" & col1 & maxrow).Value
arr2 = ws.Range(col2 & "1:" & col2 & maxrow).Value
For wrow = 1 To maxrow
key = LCase(arr1(wrow, 1))
If dicT.exists(key) = False Then
dicT(key) = 1
Else
dicT(key) = dicT(key) + 1
End If
Next
For wrow = 1 To maxrow
key = LCase(arr1(wrow, 1))
If dicT(key) = 1 Then
arr2(wrow, 1) = "ユニーク"
Else
arr2(wrow, 1) = "重複"
End If
Next
ws.Range(col2 & "1:" & col2 & maxrow).Value = arr2
End Sub

No.13 回答者： tatsumaru77 回答日時： 2022/07/07 18:33

No9です。

補足ありがとうございました。追加の補足要求です。
①大文字と小文字は、区別しないということなので、その為に、一旦全て小文字にしてから、比較するようにします。（lcase関数を使用します）
そうすると、lcaseは全角のＡを全角のａに変えます。
従って、全角の大文字と全角の小文字も区別しないことになりますが、
よろしいでしょうか。
（全角の１と半角の1は区別します）

②AM列の1行から最終行までの間に空白のセルは存在しますか。
もし、その行に対応するAO列は空白で良いのでしょうか？

この回答へのお礼

ありがとうございます。
①検査用のセルなので全て大文字か小文字に統一して問題ありません。(別のセルにオリジナル値が残ってる)
ちなみに、ASCで全て半角にして、Substituteで空白を除くクレンジング処理後のセルがAMです。よって漢字などの以外の半角に出来る文字は全て半角にしてあります。

②必須項目なので空白は存在しません。

質問ではダミーで話してます。
今更申し訳ありませんが、正確に言うと
実際にはAK列内の重複判定の書き込み先をAM列に、
AN列の判定結果をAP列に、AQ列の判定結果をAS列に、となってます。
※3回繰り返してるんです。それはマクロ内の変数を変えて手動で行う想定でした。。。

お礼日時：2022/07/07 20:59

No.12 回答者： ひでオンジ 回答日時： 2022/07/07 17:14

コメント付けて一部仕様を変更しました

セルに書込む所で遅くなる可能性になるので、遅かったらまた教えて下さい
配列に詰め込んで一気に書き込む仕様に変更します

Public Sub dup()

Dim Chofuku As Object
Dim lLoop As Long
Dim lEndRow As Long
Dim sKey As String

'ディクショナリーの作成
Set Chofuku = CreateObject("Scripting.Dictionary")

'最終行を取得
lEndRow = Cells(Rows.Count, "AM").End(xlUp).Row

'ループ
For lLoop = 1 To lEndRow

'セルの値を取得（ディクショナリーのKEYとして使う）
sKey = Cells(lLoop, "AM").Value

'ディクショナリー内にKEYが存在しなかったら
If Chofuku.Exists(sKey) = False Then

'ディクショナリーのKEYの位置にユニークという文字列を追加
Chofuku.Add sKey, "ユニーク"

'ディクショナリー内にKEYが存在したら
Else
'ディクショナリーのKEYの位置に重複という文字列に上書き
Chofuku.Item(sKey) = "重複"
End If

Next

lLoop = 0

'ループ
For lLoop = 1 To lEndRow

'KEYを取得
sKey = Cells(lLoop, "AM").Value

'ディクショナリーのKEYからユニークか重複の文字列を取得してAO列にセット
Cells(lLoop, "AO").Value = Chofuku.Item(sKey)

Next

End Sub

この回答へのお礼

テストしてみました。
すごいです！今までの手作業で見落としていた箇所も重複を検知していました。
従来の所要時間と比べたら天と地の違いで早くて楽なので十分ですが、
もっと速くなる余地があると聞いてしまうと興味はあります。
しかし贅沢な要望はスルーして頂いて大丈夫です！
ありがとうございました。

スルーついでに贅沢な要望は
判定対象の列、判定結果を書き込む列をすぐ変更できるように変数化されると嬉しいです。（作業の都合で、列挿入とかすると動いてしまうので）

お礼日時：2022/07/07 21:09