連番が割り振られたセルをテーブル形式に並び替えたい

こんばんは！いつも質問させていただいている、Nieと申します。
仕事で始めたVBAですが、その奥深さにどっぷりはまっている者です！！

今、添付画像のように、アルファベットが入っているセルにのみ、番号が割り振られているシートがあります（※自分で本文最下部にあるコードを作成ために便宜上わりふっているだけです）
これを画像の黄色のテーブルのように並び替えたいのですが、上手くいかないため、VBAにお詳しい方！どなたか、この要望を叶えるコードをご教示いただけないでしょうか！？
（ちなみに自分でコードを書いてみたら、F列からI列に１行ずつずれて値が入りました。恥）

尚、恥ずかしながら自身で書いてみたコードは下記のとおりです。
これだと、仮に連番が増えたり、テーブルの行・列が増えた場合の処理が非常に大変です＞＜。。。
「こんなコードは全くなってない！けしからん！」ということであれば、
全く１から異なるコードをご提示いただくのでももちろん構いません（それはそれで狂喜乱舞します）

お手数をおかけしてしまいますが、ご回答おまちしております＞＜。。。。
記=================================
Sub 並び替え()
Dim iRow As Long
iRow = 0
For iRow = 1 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(iRow, "A") = 1 Then
Cells(iRow, "F") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 2 Then
Cells(iRow, "G") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 3 Then
Cells(iRow, "H") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 4 Then
Cells(iRow, "I") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = "" Then
Cells(iRow, "I") = Cells(iRow, "A")
ElseIf Cells(iRow, "A") = 5 Then
Cells(iRow, "F") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 6 Then
Cells(iRow, "G") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 7 Then
Cells(iRow, "H") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 7 Then
Cells(iRow, "I") = Cells(iRow, "B")
ElseIf Cells(iRow, "A") = 8 Then
Cells(iRow, "I") = Cells(iRow, "B")
jRow = iRow + 1
End If
以上=================================

何卒よろしくお願いします。。。。

No.1 ベストアンサー 回答者： tom04 回答日時： 2016/04/22 22:58

こんばんは！

C列の並びは無視して単純にF列～I列に黄色い並びになるようにしてみました。

Sub Sample1()
Dim i As Long, k As Long, myArea As Range
For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "A") = 1 Then
k = i
Set myArea = Cells(Rows.Count, "F").End(xlUp).Offset(2).Resize(2, 4)
Do While Cells(k, "A") <> ""
myArea(Cells(k, "A")) = Cells(k, "B")
k = k + 1
Loop
i = k
End If
Next i
End Sub

※　おそらくご希望は他の操作があるのだと思いますが、
まずはこの程度で・・・m(_ _)m

この回答へのお礼

tom04様

ご回答誠にありがとうございます！！
この質問を投稿した時点で、もしかしたらtom04様からまた回答いただけるかな？などと期待してしまっていました（笑）
そして、ご回答のコードを試した結果、私が意図していたことが実現していましたーーー―！！
しかも、とってもコンパクトで分かりやすかったです。。
本職はプログラマさんかなにかなのでしょうか？？
またお世話になるかもしれませんが、今後共何卒よろしくお願い致します。
ありったけの感謝を込めて、ベストアンサーに選ばせていただきます❤

お礼日時：2016/04/23 21:45

No.3 回答者： WindFaller 回答日時： 2016/04/26 15:39

こんにちは。

私は、行列で、この問題を解いてみました。その行列式を考えつくまでに、数日を掛かってしまいましたが、まだ開いているようなので、一応、アップロードさせていただきます。

後出しのアップロードのつもりはないのですが、オブジェクトも使わないで、配列も使わずに、行列だけで作るというのは、久々に頭を使いました。単純な仕組みほど、力を試されるものかもしれませんね。

この2行4列、1空行のブロックがなければ、本当は簡単だと思います。
3-4, 6-7, 9-10, 12-13, 15-16,....
なぜ、こんなブロックを作ったのだろうか、と恨み言一言言いたくなりましたね。（^^;

たぶん、質問の元のコードの延長的な考え方に近いと思っています。
iRow(以下では j) は、書き込み用には使えないという所が、難しいところです。なお、変数は、思いつきなので、統一性がありません。
IsNumericで数値を拾うという意味だけで、すべて値のない部分によって改行が加わります。9個以上の連番の場合は、1行開けて次のブロックに入ります。画面がちらつくようなら、ScreenUpdating =False を入れてください。

'//
Sub 並び替え2()
　　Dim j As Long　'カウンタ変数
　　Dim i As Long　'列数
　　Dim m As Long　'相対的な行数
　　Const t As Long = 3 '初期の行数位置
　　j = 1
　　m = 0
'　　Range("F1:I100").ClearContents　'値を消す
　　Do
　　　　If Cells(j, "A").Value <> "" Then
　　　　　　If IsNumeric(Cells(j, "A").Value) Then
　　　　　　　　Cells(t + m - 1, "F").Offset(, i).Value = Cells(j, "B").Value
　　　　　　　　If (i + 1) Mod 4 <> 0 Then
　　　　　　　　　　i = i + 1
　　　　　　　　Else
　　　　　　　　　　i = 0
　　　　　　　　　　m = m + 1
　　　　　　　　End If
　　　　　　　　flg = True
　　　　　　End If
　　　　ElseIf flg Then　'連続の値が途切れた時は、間を開ける
　　　　　　　　m = Int(m / 4) * 3 + 4: i = 0
　　　　　　　　flg = False
　　　　End If
　　　　'通常は、1行ずつだけど、次が、3で割れたら、1行開ける
　　　　If (m Mod 3) = 0 Then m = m + 1
　　　　j = j + 1
　　Loop Until Cells(j, "B").Value = ""
End Sub
'//

この回答へのお礼

WindFaller様

はっ！ベストアンサーを既に選んだつもりだったのですが開放されていたことにはじめて気がつきました汗
ご回答本当にありがとうございます！

行列を使用されているとのこと、色んな方法があるものですね…！！帰宅したら是非実行させてください！

今回の質問に関しては既に解決済みでしたが、今VBAにはまり、勉強中なのでまた質問をさせていただくこともあるかと思います。

末永くよろしくお願いいたします(*´∀`)

お礼日時：2016/04/26 22:08

No.2 回答者： tokuma. 回答日時： 2016/04/23 10:52

Option Explicit

Option Base 1

Private Const DATA_COLS_COUNT As Integer = 4
Private Const DATA_ROWS_COUNT As Integer = 2

Sub MainSub()
Dim xlsSheet As Worksheet
Dim objRowdata(DATA_ROWS_COUNT, DATA_COLS_COUNT) As Variant
Dim intLastRow As Integer
Dim intRowCount As Integer
Dim intDataContinueCol As Integer
Dim intDataContinueRow As Integer
Dim intDataWriteRowIndex As Integer
Dim blnBeforeHeadNull As Boolean
Dim strHead As String

Set xlsSheet = ThisWorkbook.Worksheets("Sheet1")
' xlsSheet.Range("F:I").Clear
xlsSheet.Columns(6).Resize(, DATA_COLS_COUNT).Clear

intLastRow = xlsSheet.Range("A1").SpecialCells(xlLastCell).Row
blnBeforeHeadNull = True
intDataWriteRowIndex = 3 - 1
For intRowCount = 1 To intLastRow + 1
strHead = Trim$(CStr(xlsSheet.Cells(intRowCount, 1).Value))
If strHead = "" Then
If blnBeforeHeadNull = False Then
Call ExcelWrite(xlsSheet.Range("F" & intDataWriteRowIndex), objRowdata)
blnBeforeHeadNull = True

intDataWriteRowIndex = intDataWriteRowIndex + DATA_ROWS_COUNT
End If
Else
If blnBeforeHeadNull = True Then
' intDataWriteRowIndex = intRowCount
intDataWriteRowIndex = intDataWriteRowIndex + 1
Call RowDataClear(objRowdata)
blnBeforeHeadNull = False

intDataContinueCol = 1
intDataContinueRow = 1
objRowdata(intDataContinueRow, intDataContinueCol) = Trim$(CStr(xlsSheet.Cells(intRowCount, 2).Value))
Else
intDataContinueCol = intDataContinueCol + 1
If intDataContinueCol > DATA_COLS_COUNT Then
intDataContinueCol = 1
intDataContinueRow = intDataContinueRow + 1
End If
objRowdata(intDataContinueRow, intDataContinueCol) = Trim$(CStr(xlsSheet.Cells(intRowCount, 2).Value))
End If
End If
Next

End Sub

Private Sub RowDataClear(arrayData() As Variant)
Dim index1 As Integer
Dim index2 As Integer
For index1 = LBound(arrayData, 1) To UBound(arrayData, 1)
For index2 = LBound(arrayData, 2) To UBound(arrayData, 2)
arrayData(index1, index2) = Empty
Next
Next
End Sub

Public Sub ExcelWrite(ByVal TopCell As Excel.Range, ByRef DataX() As Variant)
With TopCell.Resize(UBound(DataX, 1) - LBound(DataX, 1) + 1, UBound(DataX, 2) - LBound(DataX, 2) + 1)
.Value = DataX
.Interior.Color = RGB(255, 255, 0)
End With
End Sub

この回答へのお礼

tokuma.様

お礼が遅くなり、申し訳ありません！！
丁寧にコードを書いていただき感謝感激です。。が、私の勉強がたりず、上手くコードが理解できないでおります・・・。
時間をかけて読み込ませていただきますね。ありがとうございました。

お礼日時：2016/04/23 21:40