●顧客IDが無い場合の、顧客名簿の重複削除の方法
基本的には、顧客IDが無い場合の、顧客名簿の重複削除の方法・・・・、ですが、顧客IDがあったとしても、入力ミスでダブって入力したり（顧客ID違いで内容が全部同じ）、ですとか、「家族」をバラバラに「独立した１人の顧客として」顧客名簿に入力してしまったり、色んな入力ミスがありますから、一応、そういうミスが無いかも、これでチェックできます。
(01) ●まずは氏名でチェック
単純にピボットで氏名でチェック。
以下のコードも作成。ドリルスルーをしやすくするために。
コマンドボタン化するか、ショートカットキー割り当てをするとラクちん。
ピボット内のセルを一つ選択してから実行する。
ドリルスルーして、２行分を選択したのちクリップボードに送ってくれるので、重複チェック対象をテキストファイルにコピペメモするのに使えます。
ドリルスルー後のコピー行数は必要に応じて変更します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
' ' Sub DMリストドリルスルーと行選択() ' ' Macro2 Macro ' マクロ記録日 : 2026/6/16 ユーザー名 : a ' ' ' Range("B7").Select Selection.ShowDetail = True Rows("2:3").Select Selection.Copy ' Rows("5:5").Select ' ActiveSheet.Paste End Sub ' ' |
2025/11/07～12の、「ｘｘｘｘご依頼：DMリスト重複調査→」でフィルタするとわかりやすい。
総合連番 削除区分 部分連番 お届け先名 お届け先郵便番号 お届け先住所 お届け先建物名（アパートマンション名） お届け先電話番号 顧客ID お届け先会社・部門１ お届け先会社・部門２ お届け先名略称ｶﾅ 敬称 ご依頼主電話番号 区分01 区分02 区分03 区分04 区分05
(02) ●ご家族疑いチェック その１ （=LEFT(E2,1)&RIGHT(G2,1)）
「=LEFT(E2,1)&RIGHT(G2,1)」を埋め込む列の名前は「家族疑いフラグ」。
「家族疑いフラグ」の列は、このあと、いろんなチェックフラグ（数式での）に流用します。
※「〇〇県」「〇〇〇市」「番地」を順番に置換で消して、「家族疑いフラグ用住所01」とする。
その後、「氏名」の先頭1文字と「家族疑いフラグ用住所01」の最後の1文字でチェック。
チェック用のマクロあり。
どれを消すかは、普通に「削除区分」の列で「４番・・真っ先に削除」などをフラグを立てた。
総合連番 氏名 郵便番号 家族疑いフラグ用住所01 住所02 電話番号 顧客ID 家族疑いフラグ お届け先住所 削除区分 部分連番 お届け先会社・部門１ お届け先会社・部門２ お届け先名略称ｶﾅ 敬称 ご依頼主電話番号 区分01 区分02 区分03 区分04 区分05
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
' ' Sub DMリストドリルスルー縮小表示と並べ替え() ' ' Macro2 Macro ' マクロ記録日 : 2026/6/16 ユーザー名 : a ' ' ActiveCell.Offset(1, 0).Select ' Range("B7").Select Selection.ShowDetail = True ActiveWindow.Zoom = 80 Range("D1").Select Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin ' Rows("5:5").Select ' ActiveSheet.Paste End Sub ' ' |
(03) ●ご家族疑いチェック その２ （=LEFT(E2,1)&RIGHT(G2,1)）
「氏名」の先頭1文字と「電話番号」の最後の1文字でチェック。
「家族疑いフラグ」にて。
(04) ●氏名の列を複製し、スペース（半角・全角ともに）を削除して、再度、単純比較
ピボットの時点で重複ゼロだった。
(05) ●電話番号のみで単純比較
ドリルスルー結果にて、「削除区分」の列だけ移動して、ここにコピペメモ。
総合連番 削除区分 氏名スペースなし区分 氏名 郵便番号 家族疑いフラグ用住所01 住所02 電話番号 顧客ID 家族疑いフラグ お届け先住所 部分連番 お届け先会社・部門１ お届け先会社・部門２ お届け先名略称ｶﾅ 敬称 ご依頼主電話番号 区分01 区分02 区分03 区分04 区分05
(06) ●住所のみでもチェック
（愛知県、名古屋市、番地、カットしたもので）
２８件ほどだったので、手作業でチェック→でも無かったのでスルー。
ピボットは都度消した。
(07) ●=RIGHT(G2,1)&RIGHT(I2,1)で住所の最後の１文字と、TELの最後尾の１文字でチェック。
「家族疑いフラグ」にて。
ピボットで調べたら１７０件ほどもあったので、クリックが大変だから、
ドリルスルーチェックをマクロ化
で、結局チェックしたら怪しいやつはゼロ。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
' ' Sub 重複チェック名前1文字住所最終1文字() ' ' Macro2 Macro ' マクロ記録日 : 2026/3/27 ユーザー名 : a ' ' ' Range("B12").Select Selection.ShowDetail = True Range("G2").Select Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin ActiveWindow.Zoom = 70 ' Columns("A:C").Select ' Range("C1").Activate Columns("A:C").ColumnWidth = 2 End Sub ' ' |
(08) ●=RIGHT(G2,2)&RIGHT(I2,2)で住所の最後の２文字と、TELの最後尾の２文字チェック。
「家族疑いフラグ」にて。
住所の最後の１文字と、TELの最後尾の１文字ですでにやってるので、無意味。
やらない。
(09) ●=LEFT(H29,2)&RIGHT(E29,1)&RIGHT(L29,1)で、名前の２文字と、住所の最後の１文字、電話の最後の１文字。
「家族疑いフラグ」にて。
「氏名」の先頭1文字と「家族疑いフラグ用住所01」の最後の1文字ですでにやってるので無意味かも？
やるなら、名前の２文字と、電話の最後の１文字でやる？
(10) ●=LEFT(E2,2)&RIGHT(G2,2)で名前の先頭の２文字と、住所の最後尾の２文字チェック。
「氏名」の先頭1文字と「家族疑いフラグ用住所01」の最後の1文字ですでにやってるので無意味。
やらない。
(11) ●ラストに、社長様の削除対象顧客と、「DM絶対禁止のお客様.xls」を照らし合わせる。
完全一致と、姓だけの前方一致と２ケースで。
SELECT *
FROM ４表合体＿加工
WHERE (((氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"
Or (氏名) Like "氏名01*"))
ORDER BY 氏名;
(12) ●ラストのラストに、４表結合orgや、再度、ほぼいじってない新しい４表結合をしたものでAccessファイルにてチェック。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
●実際に使うように個人用マクロブックに作ったコード。
ミニツールバーに、イエローマクロボタン化して使います。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
' ' 実際に使っているコード。 イエローボタン、左から PERSONAL.XLS!個人用MB専用_DMリストドリルスルーと行選択と別ブックへのコピペ PERSONAL.XLS!アクティブシートの削除 PERSONAL.XLS!個人用MB専用_DMリストドリルスルー縮小表示と並べ替え '######################################################################################################### 'ピボットの選択セルをドリルスルーした際の内容を、そのまま、別ブックの別シートへコピペする。 'コピペ完了後は、ピボットの選択セルが１つ下に下がる。 'あらかじめ、「別ブックの別シート」を開いておかないといけない。 'ただ、開いてなければエラーが出てピボットの選択セルはそのままで、ドリルスルーしたシートも消える。 'なお、ピボットのあるシート、で、かつ、ドリススルーできるセルがアクティブになってないと動かない。 'コピペ先のブックやシートの名前を先に手動編集する必要がある。 ' '以下のようなことに使える。 '●氏名での単純比較 '●氏名の列を複製し、スペースを削除しての、再度の単純比較 '●電話番号のみで単純比較（２世帯住宅、同じ敷地内、の疑い） '●住所のみでもチェック（愛知県、名古屋市、番地、カットしたもので） ' ↑必要に応じて、「DMリストドリルスルー縮小表示と並べ替え()」と併用する。 '######################################################################################################### Sub 個人用MB専用_DMリストドリルスルーと行選択と別ブックへのコピペ() Dim s_TrgWBNm01 As String '転記先ブックの名前 Dim s_TrgWsNm01 As String '転記先シートの名前 Dim s_TrgWsClmForLastRow As String '転記先シートの､最終行をチェックするための、その列の番号 Dim s_TrgWsPastCelClm As String '転記先シートのペースト基点となるセルの、その列の番号 Dim o_DrilWs As Worksheet 'ドリルスルーしたシート Dim s_DrilWsClmForLastRow As String 'ドリルスルーしたシートの最後の行を調べるための、その列の番号 Dim l_DrilWsLastRow As Long 'ドリルスルーしたシートの最後の行。 Dim s_DrilSrcRngAdr As String 'ドリルスルーしたシートの、コピー元のセル範囲の列番号（どこまでの列をコピーするかの指定のために） Dim o_DrilSrcRng001 As Range 'ドリルスルーしたシートのコピー元のセル範囲のRangeオブジェクト用 Dim l_Answ As Long '「CopyRangeToDest()」関数＝セル範囲のコピペ実行のプロシージャの成功・失敗のフラグ格納用 ' Dim l_NextRow As Long '●設定事項 Let s_TrgWBNm01 = "テスト貼り付け用.xls" '貼り付け先のブック名を設定 Let s_TrgWsNm01 = "Sheet1" '貼り付け先のシート名を設定 Let s_TrgWsClmForLastRow = "A" '転記先シートの、最終行をチェックするための、その列の指定（空白セルが絶対に発生しない列番号で。） Let s_TrgWsPastCelClm = "A" '転記先のペースト基点となるセルの列の指定（行数はあとで「CopyRangeToDest()」関数の側で最新行を自動取得。） Let s_DrilWsClmForLastRow = "A" '（ドリルスルーしたシートの）コピー元セル範囲の最終行をチェックするための、その列の指定（空白セルが絶対に発生しない列番号で。） Let s_DrilSrcRngAdr = "A2:Z" '（ドリルスルーしたシートの）コピー元のセル範囲の指定（行数はあとで「CopyRangeToDest()」関数の側で最新行を自動取得。） Let l_Answ = 0 '一応念のために初期化 ' 削除時の警告画面を非表示にする Application.DisplayAlerts = False '●メイン ' ユーザーがピボット上で選択したセルのドリルスルーを実行 Selection.ShowDetail = True ' 新しく開いたドリルスルーシートを変数にセット Set o_DrilWs = ActiveSheet ' ドリルスルーシートのコピー元セル範囲の行数を求める。 ' 今回はA列を使う。 ' A列は総合連番のため、値の抜けが無いので。 ' A列のデータが存在する最終行を取得 l_DrilWsLastRow = o_DrilWs.Cells(o_DrilWs.Rows.Count, s_DrilWsClmForLastRow).End(xlUp).Row ' --- 別のファイルへの転記処理 --- On Error Resume Next ' もし全くデータがないシートの場合は何もしない If l_DrilWsLastRow >= 2 Then 'ドリルスルーのシートの、２行目から最終行のセル範囲をゲット。 Set o_DrilSrcRng001 = o_DrilWs.Range(s_DrilSrcRngAdr & l_DrilWsLastRow) 'それを転記先ブックの指定したシートの、指定した列（今回はA列）に転記。 Let l_Answ = CopyRangeToDest(o_DrilSrcRng001, _ s_TrgWBNm01, _ s_TrgWsNm01, _ s_TrgWsClmForLastRow, _ s_TrgWsPastCelClm) Else End If ' --- シートの削除処理 --- ' ドリルスルーしたシートを削除 o_DrilWs.Delete 'もしコピペが成功すれば、ピボットのシートの次の行（セル）に下がる。 '（失敗したら下がらない。） If l_Answ = 0 Then ActiveCell.Offset(1, 0).Select Else End If ' 警告画面の表示を元に戻す Application.DisplayAlerts = True ' メモリの解放 Set o_DrilWs = Nothing End Sub '######################################################################################################### '個人用MB専用_DMリストドリルスルーと行選択と別ブックへのコピペ()関数から '呼び出されるプロシージャ。 '画面をSelectすることなくセル範囲のコピペができる。 '転記先のブックやシートが開いてなければ中断し、「失敗」のフラグとして「１」を返す。 '######################################################################################################### Function CopyRangeToDest(o_SrcRng As Range, _ s_TrgWbNm As String, _ s_TrgWsNm As String, _ s_TrgLastRowClmNm As String, _ s_TrgPastCelClmNm As String) As Long Dim o_TrgWb As Workbook Dim o_TrgWs As Worksheet Dim l_TrgNewRow As Long ' 1. 転記先ブックとシートの存在チェック（エラー対策） On Error Resume Next Set o_TrgWb = Workbooks(s_TrgWbNm) '転記先ブックが開いてないと、「Nothing」が入る。 Set o_TrgWs = o_TrgWb.Worksheets(s_TrgWsNm) '同上 On Error GoTo 0 If o_TrgWb Is Nothing Then MsgBox "転記先ブック「" & s_TrgWbNm & "」が開かれていません。", vbCritical Let CopyRangeToDest = 1 '転記先が開いてなかったら１を返す。成功した時は明示的に自動で 0 を返すのでOK。 Exit Function End If If o_TrgWs Is Nothing Then MsgBox "転記先シート「" & s_TrgWsNm & "」が見つかりません。", vbCritical Let CopyRangeToDest = 1 '転記先（しーと）が開いてなかったら１を返す。成功した時は明示的に自動で 0 を返すのでOK。 Exit Function End If ' 2. 転記先シートのA列の最終行を取得し、その下の行（次の書き込み行）を決定 ' ※Excel 2000の最大行数（65536行）に対応するため Rows.Count を使用 l_TrgNewRow = o_TrgWs.Cells(o_TrgWs.Rows.Count, s_TrgLastRowClmNm).End(xlUp).Row + 1 ' ' ※もし転記先シートが完全に空で、1行目から書き込みたい場合の簡易判定 ' If l_TrgNewRow = 2 And o_TrgWs.Cells(1, "A").Value = "" Then ' l_TrgNewRow = 1 ' End If ' 3. データのコピー＆ペースト（値だけでなく書式等も丸ごとコピーする場合） o_SrcRng.Copy o_TrgWs.Cells(l_TrgNewRow, s_TrgPastCelClmNm) ' 4. コピーモードの解除（点滅枠線を消す） Application.CutCopyMode = False End Function '##################################################################### 'アクティブシートの削除() '##################################################################### Sub SendKeys "{Enter}", False ActiveSheet.Delete End Sub '######################################################################################################### 'ドリルスルーしたシートを並べ替えて、全体が見やすいように縮小表示したり、 '不要な列の幅をせばめます。 'ただし、不要列の列幅をせばめるには、コードを直接いじらないといけないです。 '以下のようなことに使えます。 '●ご家族疑い その１（「氏名」の先頭1文字と「家族疑いフラグ用住所01」の最後の1文字でチェック。） '●ご家族疑い その２（「氏名」の先頭1文字と「電話番号」の最後の1文字でチェック。） '●住所の最後の１文字と、TELの最後尾の１文字でチェック。 ' ↑必要に応じて、「New01_DMリストドリルスルーと行選択と別ブックへのコピペ()」と併用する。 ' '######################################################################################################### Sub 個人用MB専用_DMリストドリルスルー縮小表示と並べ替え() ' ' Macro2 Macro ' マクロ記録日 : 2026/6/16 ユーザー名 : a ' ' Range("B7").Select Dim o_Wb As Workbook Dim o_Ws As Worksheet Dim o_DetailWs As Worksheet 'ドリルスルーしたシート指定用 Dim s_CelAddr01 As String '並べ替えする列の指定用（セルとして指定） Dim l_SortOrder As XlSortOrder '並べ替えの順序（昇順/降順）の指定用 '●設定事項 Let s_CelAddr01 = "C1" '←ドリルスルーしたシートの中で、 ' 並べ替えしたい列をセルで指定。 Let l_SortOrder = xlAscending '←ここで、並べ替えが、 ' 「xlAscending（昇順）」か ' 「xlDescending（降順）」かを指定。 '●メイン ' 削除時の警告画面を非表示にする Application.DisplayAlerts = False Set o_Wb = ActiveWorkbook Set o_Ws = ActiveSheet Selection.ShowDetail = True 'ドリルスルーを実行。 Set o_DetailWs = ActiveSheet '表示されたそのシートをオブジェクト変数に格納。 ActiveWindow.Zoom = 80 '８０％に縮小表示。 ' o_DetailWs.Range(s_CelAddr01).Select '↑並べ替えしたい列を指定。変数s_CelAddr01にて。 ' '↑※並べ替えで直接セルを指定するようにしたので、 ' この「Select」は不要になった。コメントアウト。 '並べ替え開始（Selectはしないで） o_DetailWs.Range(s_CelAddr01).Sort _ Key1:=o_DetailWs.Range(s_CelAddr01), _ Order1:=l_SortOrder, _ Header:=xlGuess, _ OrderCustom:=1, _ MatchCase:=False, _ Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin '↑「Order1:=l_SortOrder, _ 」にて、 ' 変数（l_SortOrder）を使って、昇順降順を指定 'チェックに重要な意味ではない列を狭める o_DetailWs.Columns(3).ColumnWidth = 2.5 '０１（必要に応じて変える） ' o_DetailWs.Columns(4).ColumnWidth = 2.5 '０２（必要に応じて変える） o_Wb.Activate '←必須 o_Ws.Activate ActiveCell.Offset(1, 0).Select o_DetailWs.Activate ' 警告画面の表示を元に戻す Application.DisplayAlerts = True ' メモリの解放 Set o_DetailWs = Nothing Set o_Wb = Nothing Set o_Ws = Nothing ' Rows("5:5").Select ' ActiveSheet.Paste End Sub ' ' |
