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

Question

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

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列部分を変更

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

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

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

keithin · Accepted Answer

わかりやすけど遅いマクロ：
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

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

MarcoRossiItaly · Answer

＞……などすべき項目が多く、プログラムが長くなる予感がしたため、……
 
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

MarcoRossiItaly · Answer

＞例文のため、A列には「あ?か」の順で入力していますが、　実際は最後に「青木」とか入るかもしれません。
　しかし、順番は変えたくなく、入れた順番で追加されていくような方式が良いのです。
 

質問者さんによる事実誤認です。
 
No.2 で回答したとおり、通し番号を振っておき、後で通し番号の順によって並べ替えれば、行がどれだけシャッフルされていても、順番はいつでも元どおりになります。どの位置に「青木」が記入されようが、何の関係もありません。
 
もっと言えば、No.2 では、「か」だか「青木」だかに当たるデータを記入する位置について、既存データの下端に付け加えると言いましたね。したがって No.2 の場合、既存データの順番は一度も入れ替わることなく、追加すべき行が必要な位置に挿入されたことになりますが。問題視すべきことは何もないですね。
 
プログラミングでは、単に文法を覚えるだけではなく、どのような手法で目的を達成するかということがたいへん重要です。No.2 のようなシンプルな方法でできるのであれば、回答者としては当然、そういったものを優先して提案するのです。マクロによらず手作業で行う場合でも、同じことが言えます。

MarcoRossiItaly · Answer

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)の列で並べ替え

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

わかりやすけど遅いマクロ：

この回答への補足

<br /> ＞……などすべき項目が多く、プログラムが長くなる予感がしたため、……<br /> <br /> No.2 の

＞例文のため、A列には「あ?か」の順で入力していますが、 実際は最後に「青木」とか入るかもしれません。

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

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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

＞例文のため、A列には「あ?か」の順で入力していますが、　実際は最後に「青木」とか入るかもしれません。