重複数字を切り取り空いた隙間を右詰めするには？

質問

どなたかご存知でしたら回答をお願いします。
【質問】
下図の様に５×５のセルが２つあり、それぞれ１~９９迄の数字がランダムに
重複有りで入っています。５×５のセルの中には行の連続数字（例：02　03）
が入っています（１個も無い場合もあります。１行全部（5個）の場合もあります。）。
行の連続数字を見つけたら、その連続数字を切り取り「◎重複数字」の下に順番に
並べていき、切り取られた空白箇所を埋めるために左側にある数字を右に詰める
方法が知りたいです。
【例題】
A　B　Ｃ　D　Ｅ　 Ｆ　　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　　
1　0107091122　　　　　0310203031
2　0412141523　　　　　0102070922
3　0713171825　　　　　0411121415
4　0616212426　　　　　0213171823
5　0819272829　　　　　0607080910

【実行後】
A　B　Ｃ　D　Ｅ　Ｆ　　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　　
1　0107091122　　　　　　　　　　031020
2　　　041223　　　　　　　　　　070922
3　　　071325　　　　　　　　　　　　04
4　0616212426　　　　　　　　　　021323
5　　　　0819　　　　　　　　　　
◎重複数字
14　15　　　　　　　　　30　31
17　18　　　　　　　　　01　02
27　28　29　　　　　　　11　12　
　　　　　　　　　　　　 14　15
　　　　　　　　　　　　 17　18
　　　　　　　　　　　　 06　07　08　09　10　　　　　　
【注意事項】
　・使用するエクセルは２０１０です。
　・セルの中の数字は２桁で表しています。（例：1ではなく01）
　・５×５のセルの位置は下記のとおりです。
　　　１個目の５×５マス・・・A1~Ｅ５
　　　２個目の５×５マス・・・G1~Ｋ５　
　　　※Ｆ列は空白列として空けています。　
　・回答はＶＢでも関数でも構いません。

以上、よろしくお願いします。

回答No.1

watabe007 · ベストアンサー

「◎重複数字」は文字列としてA列及びG列に有るものとしています。
Sub Test()
Dim StartCell As Range, c As Range, PasteCell As Range
Dim Count As Long, i As Long, j As Long, k As Long, L As Long
Dim v As Variant

For Each c In Range("A1:K5")
If c.Column <> 6 And Val(c.Value) + 1 = Val(c.Offset(, 1).Value) Then
If StartCell Is Nothing Then Set StartCell = c
Count = Count + 1
ElseIf Count > 0 Then
If c.Column < 6 Then
Set PasteCell = Cells(Rows.Count, "A").End(xlUp).Offset(1)
Else
Set PasteCell = Cells(Rows.Count, "G").End(xlUp).Offset(1)
End If
With Range(StartCell, c)
.Copy PasteCell
.ClearContents
End With
Set StartCell = Nothing
Count = 0
End If
Next
'後始末
For i = 1 To 5
For j = 1 To 7 Step 6
With Cells(i, j).Resize(, 5)
v = .Value
.ClearContents
L = 5
For k = 5 To 1 Step -1
If v(1, k) <> "" Then
.Item(L).Value = v(1, k)
L = L - 1
End If
Next
End With
Next
Next
End Sub

お礼

いつも回答頂きありがとうございます。
今回もバッチリ目的が達成できました。
またよろしくお願いします。