ブロック単位での並べ替えのVBA

質問

Excel2007で名簿を作成しています。
新規のデータがあれば、表の一番下に足していくのですが、
新規データを入れた後にあいうえお順に並べ替えをしたいと思います。

名簿にはたくさんの項目があり、1件につき　4行7列　を使用しており、
セルの結合をしている個所もあります。

上手く並べ替えるVBAを教えていただきたく、ご質問させていただきます。

名簿のB13:B14(結合セル）、B17:B18、B21:B22・・・・・にひらがなで名前が入っているので、
このB列をもとにあいうえお順にしたいと思っています。
（B15:B16、B19:B20、B23:B24・・・・には、漢字で名前が入っています）

以前同じ質問をさせていただきましたが、なかなかアドバイスをいただけず、
自分でも考えてみましたが、うまくいかないため、再質問をさせていただきました。

お詳しい方、どうぞよろしくお願いいたします。

回答No.1

keithin · ベストアンサー

結合セルを交えた表なので，エクセル本来の並べ替え機能は使えません。
というワケで並べ替えを自前でマクロの中でプログラムしてやる事になりますがメンドクサイので，エクセルの機能だけで実現してみます。

前提：
＞名簿のB13:B14(結合セル）、B17:B18、B21:B22・・・・・にひらがなで名前が入っているので、

名簿の本体は「１３行目から始まっている」とします。
その上にあるだろうタイトル行は無視です。

Sub macro1()
　Dim sz As Worksheet
　Dim sx As Worksheet
　Dim s0 As Worksheet
　Dim i As Long
　Dim n As Long

’気になるなら次の行のコメントアウトを外す
’application.screenupdating = false
　Set s0 = Worksheets("名簿のシート")　'試す前に名簿のシート名を記入すること
　Set sx = Worksheets.Add

’データ採取
　For i = 13 To s0.Range("B65536").End(xlUp).Row Step 4
　If s0.Cells(i, "B") <> "" Then
　n = n + 1
　sx.Cells(n, "A") = s0.Cells(i, "B")
　sx.Cells(n, "B") = i
　End If
　Next i

’並べ替え
　sx.Range("A:B").Sort key1:=sx.Range("A1"), order1:=xlAscending, header:=xlNo
　Set sz = Worksheets.Add
　For i = 1 To n
　s0.Cells(sx.Cells(i, "B"), "A").Resize(4, 1).EntireRow.Copy Destination:=sz.Cells(13 + (i - 1) * 4, "A")
　Next i

’復元
　sz.Range("A13").Resize(n * 4, 1).EntireRow.Copy Destination:=s0.Range("A13")
　Application.DisplayAlerts = False
　sx.Delete
　sz.Delete
　Application.ScreenUpdating = False

End Sub

お礼

早々のご回答、そして訂正のコメントをいただきましてありがとうございました。

いま、アドバイスいただいたとおりにやってみましたら
できました！！

こんなにシンプルな感じでできるとは思っていなかったので、
とても驚いています。
これから、どのようになっているのか、よく見て勉強します。

大変助かりました。

ありがとうございました！！

回答No.2

keithin

最後に思いつきで書き足したら間違いちゃいました。

マチガイ：
最後の
Application.ScreenUpdating = False

訂正：
Application.ScreenUpdating = True
Application.DisplayAlerts = True

失礼しました。