Excel オートフィルタで抽出＆追加 VBA

質問

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

VBAで、データベースのようなものを作っています。

　　　A　　　B　　　C　　　D　　　E　　　F
1　 　あ　北海道
2　 　い　北海道
3　 　う 　北海道
4　 　え　北海道
5　 　あ　青森
6　 　い　青森
7　 　う 　青森
8　 　え　青森
9　　 あ　東京
10　　い　東京
11　　う 　東京
12　　え　東京

このような感じのデータが並んでおります。
A列が人名で、B列がその人のデータになります。
ここに、新しいデータを追加するプログラムを組みたいと思っています。

例）　お　を追加する場合

　　　A　　　B　　　C　　　D　　　E　　　F
1　 　あ　 北海道
2　 　い 　北海道
3　 　う 　北海道
4　 　え　 北海道
5　 　お 北海道
6　 　あ 　青森
7　 　い 　青森
8　 　う 青森
9　 　え　 青森
10　 　お　青森
11　　 あ　東京
12 　　い　東京
13 　　う 　東京
14 　　え　東京
15　 　お　東京

このようにデータを追加したいと思っています。
B列の項目数、また、A列の人名も大量にあります。
手作業でやろうにも物凄い時間がかかり、
今後もこの作業が多くなるとのことなので、プログラムを作りたいと思いました。

私の考えですが、
１．B列の重複しないデータ（例なら北海道、青森、東京）を抽出
２．抽出した項目でフィルタをかけ、そのなかの1行コピー
　　そして、その最終行を取得
３．最終行＋１？にコピーしたデータを挿入
４．コピーされた部分のA列部分を変更

これを何度も繰り返すとできるかな？と思ったのですが
やはり面倒な作業を繰り返しているようにも思えます。

何か良い方法はありませんか？
私の出した案のように地道にやっていくしかないのでしょうか…

回答よろしくお願い致します！

回答No.1

keithin · ベストアンサー

わかりやすけど遅いマクロ：
sub macro1()
　dim r as long

’全体がＢ列で並べ替え済みなら次の一行不要
　range("A:B").sort key1:=range("B1"), order1:=xlascending, header:=xlnone

　for r = range("B65536").end(xlup).row to 1 step -1
　　if cells(r, "B") <> cells(r + 1, "B") then
　　　rows(r + 1).insert shift:=xlshiftdown
　　　cells(r + 1, "A") = "お"
　　　cells(r + 1, "B") = cells(r, "B")
　　end if
　next r
end sub

リストのタイトル行も用意されていない状況という事なので，それに合わせて作成しました。
適切に応用して実用して下さい。

お礼

回答ありがとうございます。
おかげで、思ったとおりのものが出来ました！
思ってたより追加動作も速く、助かりました。
ありがとうございました！

補足

回答ありがとうございます。
申し訳ありません、記入ミスでした。
リストのタイトル行はあり、オートフィルタがかかってします。

回答No.4

MarcoRossiItaly

＞……などすべき項目が多く、プログラムが長くなる予感がしたため、……

No.2 の工程を実装したので、お気に召さないかもしれませんが、ご参考に一応載せます。

＞……をベストアンサーにさせて頂きました。

ベストアンサーには始めから関心がないので、問題ありません。

Sub PeriodicInsertion()
　　Dim psn As String, fr As Long, lr1 As Long, lr2 As Long, a As Long, b As Long, i As Long, s As Worksheet
　　psn = InputBox("追加する氏名を入力")
　　If psn = "" Then Exit Sub

　　'A1セルからデータが始まる場合に限定

　　Columns("a").Insert
　　Rows(1).Insert
　　Range("a1").Value = "番号": Range("b1").Value = "人名": Range("c1").Value = "都道府県"
　　lr1 = Cells(Rows.Count, "c").End(xlUp).Row
　　a = WorksheetFunction.CountIf(Columns("c"), Cells(lr1, "c").Value)
　　For i = 2 To lr1
　　　　Cells(i, "a").Value = Int((i - 2) / a) + 1
　　Next i
　　Set s = ActiveSheet
　　Worksheets.Add before:=Worksheets(1)
　　Range("a1").Value = "都道府県": Range("a2").Value = "<>"
　　With s
　　　　.Range("c1:c" & lr1).AdvancedFilter _
　　　　　　Action:=xlFilterCopy, criteriarange:=Worksheets(1).Range("a1:a2"), copytorange:=.Cells(lr1 + 1, "c"), unique:=True
　　　　.Cells(lr1 + 1, "c").Delete shift:=xlShiftUp
　　　　lr2 = .Cells(Rows.Count, "c").End(xlUp).Row
　　　　For i = lr1 + 1 To lr2
　　　　　　.Cells(i, "a").Value = i - lr1
　　　　　　.Cells(i, "b").Value = psn
　　　　Next i
　　　　.Range("a1:f" & lr2).Sort key1:=.Range("a1"), order1:=xlAscending, Header:=xlYes
　　End With
　　Application.DisplayAlerts = False
　　Worksheets(1).Delete
　　Application.DisplayAlerts = True
End Sub

お礼

回答ありがとうございます。
今後ともよろしくお願いいたします。

回答No.3

MarcoRossiItaly

＞例文のため、A列には「あ?か」の順で入力していますが、　実際は最後に「青木」とか入るかもしれません。
　しかし、順番は変えたくなく、入れた順番で追加されていくような方式が良いのです。

質問者さんによる事実誤認です。

No.2 で回答したとおり、通し番号を振っておき、後で通し番号の順によって並べ替えれば、行がどれだけシャッフルされていても、順番はいつでも元どおりになります。どの位置に「青木」が記入されようが、何の関係もありません。

もっと言えば、No.2 では、「か」だか「青木」だかに当たるデータを記入する位置について、既存データの下端に付け加えると言いましたね。したがって No.2 の場合、既存データの順番は一度も入れ替わることなく、追加すべき行が必要な位置に挿入されたことになりますが。問題視すべきことは何もないですね。

プログラミングでは、単に文法を覚えるだけではなく、どのような手法で目的を達成するかということがたいへん重要です。No.2 のようなシンプルな方法でできるのであれば、回答者としては当然、そういったものを優先して提案するのです。マクロによらず手作業で行う場合でも、同じことが言えます。

お礼

回答ありがとうございます。
No.1、keithin様の回答も大変シンプルで分かりやすいものでした。
私はプログラムのほうが結構しっくりくるので、
keithin様の回答を参考にさせて頂きました。
No.2、MarcoRossiItaly様の回答は分かりやすいものでしたが、
重複のないデータの抽出などすべき項目が多く、プログラムが
長くなる予感がしたため、No.1のkeithin様の回答を
ベストアンサーにさせて頂きました。

回答ありがとうございました。

回答No.2

MarcoRossiItaly

No.1 さんのように下の行から逐次挿入していくとか、別シートにコピペするとか、きっと様々な方法があるとは思いますが。

質問文のように必ず 5 行ずつとか決まっているのなら、このようにしては？

(1)どこかの列に 5 行ずつの通し番号（1,1,1,1,1,2,2,2,2,2,3,...）を振る、(2)重複のないデータ「北海道、青森、東京」を抽出（ループ、AdvancedFilter メソッドなど）、(3)(2)のデータを B16:B18 に記入、(4) A16:A18 に「か、か、か」を記入、(5)(1)の列の 16 ～ 18 行目に「1,2,3」を記入、(6)(1)の列で並べ替え

お礼

回答ありがとうございます。
申し訳ありません、確認不足でした。
なるべくこのデータもとい、このデータ以外の行や列には変更を
加えたくなく思っていました。

補足

例文のため、A列には「あ～か」の順で入力していますが、
実際は最後に「青木」とか入るかもしれません。
しかし、順番は変えたくなく、
入れた順番で追加されていくような方式が良いのです。