[Excel VBA]途中に空白行が存在するテーブル内の重複データを抽出する

前提・実現したいこと

ある発注機関の発注機関コードおよび組織名をまとめたExcelファイルから、組織名が重複しているレコードを抽出するマクロを作成しています。

Excelファイルのテーブルは以下の通りです。
A列の「ID」で重複はありません。
B列の「発注機関コード」に重複が存在しますが、今回はC列の「発注機関名」の重複のみ抽出します。
D列に「重複」の項目を追加し、C列の組織名が重複するレコードのうち、「ID」が最大値のレコードを抽出するのが目的です。
なお、1行目はテーブルのタイトル(セルA1に「発注機関マスタ」)で、2行目がテーブルの見出しになっています。
また、テーブルの途中には空白行が存在する場合があります。

発注機関マスタ

ID	発注機関コード	発注機関名
1	11111	AAA
2	22222	BBB
3	33333	CCC
4	11111	AAA

5	55555	EEE
6	11111	CCC
7	77777	GGG

8	88888	AAA
9	99999	JJJ

このテーブルから、

セルD2に「重複」の見出しを追加する
「ID」の値の大きい順に並べ替え、空白行を無くす
セルD3にCOUNTIF関数の式を入力する(自分より上の行に同じ組織名が無ければ「1」、あれば「1」より大きな数字になり増えていく)
同じ式をオートフィルで最下部までコピーする

以上の操作を行った結果が以下の通りです。

発注機関マスタ

ID	発注機関コード	発注機関名	重複
9	99999	JJJ	1
8	88888	AAA	1
7	77777	GGG	1
6	11111	CCC	1
5	55555	EEE	1
4	11111	AAA	2
3	33333	CCC	2
2	22222	BBB	1
1	11111	AAA	3

該当のソースコード

作成したソースコードは以下の通りです。
Excelの「マクロの記録」を使用しながら編集したので、不要なコードが含まれている可能性があります。もしあればご指摘いただけると幸いです。

VBA
1Option Explicit
2
3Sub sortDuplicate()
4    ' D列に見出しを追加
5    Range("D2").Select
6    With Selection.Interior
7        .Pattern = xlSolid
8        .PatternColorIndex = xlAutomatic
9        .ThemeColor = xlThemeColorDark1
10        .TintAndShade = -0.14996795556505
11        .PatternTintAndShade = 0
12    End With
13    
14    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
15    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
16    
17    With Selection.Borders(xlEdgeLeft)
18        .LineStyle = xlContinuous
19        .ColorIndex = 0
20        .TintAndShade = 0
21        .Weight = xlThin
22    End With
23    
24    Selection.Borders(xlEdgeTop).LineStyle = xlNone
25    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
26    
27    With Selection.Borders(xlEdgeRight)
28        .LineStyle = xlContinuous
29        .ColorIndex = 0
30        .TintAndShade = 0
31        .Weight = xlThin
32    End With
33    
34    Selection.Borders(xlInsideVertical).LineStyle = xlNone
35    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
36    
37    With Selection
38        .HorizontalAlignment = xlCenter
39        .VerticalAlignment = xlCenter
40        .WrapText = False
41        .Orientation = 0
42        .AddIndent = False
43        .ShrinkToFit = False
44        .ReadingOrder = xlContext
45        .MergeCells = False
46    End With
47    
48    ' 先頭行に「重複」と記入
49    ActiveCell.FormulaR1C1 = "重複"
50    ActiveCell.Characters(1, 2).PhoneticCharacters = "チョウフク"
51    
52    ' 並べ替えの範囲選択
53    Range("A2:D13").Select
54    
55    ' IDの大きい順に並べ替え
56    ActiveWorkbook.Worksheets("発注機関マスタ").sort.SortFields.Clear
57    ActiveWorkbook.Worksheets("発注機関マスタ").sort.SortFields.Add2 Key:=Range( _
58        "A3:A13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
59        xlSortNormal
60    With ActiveWorkbook.Worksheets("発注機関マスタ (4)").sort
61        .SetRange Range("A2:D13")
62        .Header = xlYes
63        .MatchCase = False
64        .Orientation = xlTopToBottom
65        .SortMethod = xlPinYin
66        .Apply
67    End With
68    
69    '　重複データのうち一番上の行を取得
70    Range("D3").Select
71    ActiveCell.FormulaR1C1 = "=COUNTIF(R3C[-1]:RC[-1],RC[-1])"
72    Range("D3").Select
73    Selection.AutoFill Destination:=Range("D3:D11")　
74    Range("D3:D11").Select
75    
76    '　ブックを上書き保存
77    ActiveWorkbook.Save
78    
79End Sub
80

発生している問題・エラーメッセージ

このマクロでは、レコードの対象範囲を絶対参照で指定し処理した上で成功しました。
ただし、今後、レコードが追加および削除される可能性があり、その度に範囲指定を変更するのは手間がかかるので、最終行を自動で指定するようにコードを修正したいと思っています。
範囲を指定するコード（.SetRangeの行）でUsedRangeに換えて試したのですが、

エラー 9 「インデックスが有効範囲にありません。」

このように表示されてしまいました。

試したこと

途中に空白行が存在するため、UsedRangeと書いても空白行の上の行までで範囲選択されてしまうことが考えられます。
空白セルを無視して最下部の行まで選択し、並び替えおよび重複抽出ができるようにしたいです。
なにか良いアイデアがありましたら、ご教示いただきますよう、何卒よろしくお願いいたします。

ken3memo

2022/02/24 08:58

ActiveWorkbook.Worksheets("発注機関マスタ").sort.SortFields.Add2 Key:=Range( _ "A3:A13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("発注機関マスタ (4)").sort .Worksheets("発注機関マスタ") と .Worksheets("発注機関マスタ (4)") コピーしたテストシート？の(4)に対してマクロ記録したのか？少し気になったりエラー 9 「インデックスが有効範囲にありません。」まぁ、 Key:=Range("A3:A13") や .SetRange Range("A2:D13") の固定を変えたい、質問とは違いますが、気になったので。あと、 With ActiveWorkbook.Worksheets("発注機関マスタ (4)").sort .SetRange Range("A2:D13") もしかして、 .SetRange .UsedRange だと、With ActiveWorkbook.Worksheets("発注機関マスタ (4)").sortに対して.UsedRange？ .SetRange Range("A2:D13") を変更したコード(.UsedRangeをどのように記述したか？)を正確に書くと、回答が得られやすいかも？エラーが回復するといいですね。

syu2048

2022/02/25 00:32

回答ありがとうございます。 "発注機関マスタ (4)"は上記の通り、コピーしたテストページです。編集し忘れていました。なので"発注機関マスタ (4)"ではなく、正しいシート名は"発注機関マスタ "です。 .SetRange Range("A2:D13") 　については、.SetRange.UsedRange　と変更したところ、「エラー450 引数の数が一致していません」というエラーが発生しました。途中の空白を無視して最終行まで範囲選択するには、どのように変更すればよろしいでしょうか。

行動規範の内容に同意します

回答2件

ベストアンサー

最終行の取得はいろいろ複雑な問題がありますので、下記を一読しておくことをお勧めします。
UsedRangeで範囲指定する場合の問題点も開設されています。

最終行・最終列の取得方法（End,CurrentRegion,SpecialCells,UsedRange）｜VBA技術解説

とりあえず質問の表なら、下記でいいでしょう。

vba
1提示の表なら、最終行の取得は下記になります。
2
3```vba
4Dim lastRow As Long
5lastRow = Cells(Rows.Count, 1).End(xlUp)

最終行が取得出来たら、範囲指定は下記のようにします。

vba
1    With ActiveWorkbook.Worksheets("発注機関マスタ (4)").sort
2        .SetRange Range("A2:D" & lastRow)

他の部分の範囲指定もどうようにしてください。

投稿2022/02/25 00:58

hatena19

総合スコア34362

syu2048

2022/02/25 05:34

回答ありがとうございます。他の範囲指定についても回答と同じようにコードを編集したところ、望み通りの結果を得られました。 Key:=Range( _"A3:A13")　⇒　Key:=Range( _"A3:A" & lastRow) Selection.AutoFill Destination:=Range("D3:D11")　 ⇒Range("D3").AutoFill Destination:=Range("D3:D" & Range("C65536").End(xlUp).Row) 最終行の取得についてはリンク先のページをよく読んで今後、応用できるようにしたいと思います。こちらをベストアンサーとさせていただきます。ありがとうございました。

行動規範の内容に同意します