エクセル VBA 複雑な行列入れ替えコピー

質問

VBAを使って複雑な行と列を入れ替えをしたいのですが？どなたか伝授していただけませんでしょうか？
　　　A　　　　B　　　　C
1　(1)
2　(2)
3　(3)
4　(1)
5　(2)
6　(3)
　・
　・
　・
1,000行以上あります。

これを
　　A　　　　B　　　　C
1　(1)　　　　(2)　　　 (3)
2　(1)　　　　(2)　　　 (3)
3　(1)　　　　(2)　　　 (3)

　　　　　・
　　　　　・
　　　　　・

という風にしたのですが・・・・
お分かりになる方よろしくお願いします。

回答No.5

vba_2007

'(1)からはじまる文字列をA列に
'(2)からはじまる文字列をB列に
'(3)からはじまる文字列をC列に
'それ以外をD列に移動させる
'念のため初期のA列情報をH列にバックアップしておく

Option Option Explicit

Sub main()

　　Dim i As Long
　　Dim A As String
　　Dim B As String
　　Dim C As String
　　Dim D As String
　　Dim E As String

　　'A列のデータ分だけループをまわす
　　With Excel.Application.ActiveSheet
　　　　For i = 1 To .Range("$A$65536").End(xlUp).Row
　　　　　　'初期化
　　　　　　A = ""
　　　　　　B = ""
　　　　　　C = ""
　　　　　　D = ""
　　　　　　E = ""
　　　　　　'A列のコピー元の行
　　　　　　A = "A" & i
　　　　　　'B～Eは、最終使用行+1(=コピー先となる空白行）
　　　　　　B = "B" & .Range("$B$65536").End(xlUp).Row + 1
　　　　　　C = "C" & .Range("$C$65536").End(xlUp).Row + 1
　　　　　　D = "D" & .Range("$D$65536").End(xlUp).Row + 1
　　　　　　E = "E" & .Range("$E$65536").End(xlUp).Row + 1

　　　　　　'A列の先頭3文字によってコピー先を振り分ける
　　　　　　'ただし、B1～E1が空白の場合でも、.End(xlUp).Row が 1 になってしまうので、
　　　　　　'その場合のみアドレス直指定で対処
　　　　　　If Mid(.Range("A:A").Cells(i, 1).Value, 1, 3) = "(1)" Then
　　　　　　　　If Range("B1") = "" Then
　　　　　　　　　　Range(A).Copy Range("B1")
　　　　　　　　Else
　　　　　　　　　　Range(A).Copy Range(B)
　　　　　　　　End If
　　　　　　ElseIf Mid(.Range("A:A").Cells(i, 1).Value, 1, 3) = "(2)" Then
　　　　　　　　If Range("C1") = "" Then
　　　　　　　　　　Range(A).Copy Range("C1")
　　　　　　　　Else
　　　　　　　　　　Range(A).Copy Range(C)
　　　　　　　　End If
　　　　　　ElseIf Mid(.Range("A:A").Cells(i, 1).Value, 1, 3) = "(3)" Then
　　　　　　　　If Range("D1") = "" Then
　　　　　　　　　　Range(A).Copy Range("D1")
　　　　　　　　Else
　　　　　　　　　　Range(A).Copy Range(D)
　　　　　　　　End If
　　　　　　'(1)～(3)のどれでもない場合は、E列にコピー
　　　　　　Else
　　　　　　　　If Range("E1") = "" Then
　　　　　　　　　　Range(A).Copy Range("E1")
　　　　　　　　Else
　　　　　　　　　　Range(A).Copy Range(E)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With

　　'A列をG列にバックアップ
　　Range("A:A").Copy Range("G:G")
　　'A列を削除
　　Range("A:A").Delete
　　MsgBox "Program End"
End Sub

回答No.4

excel_abc

'3行ずつがセットになっていて2行目、3行目を1行目と同じ行の
'列方向持ってくるというだけなら。

Sub 処理()
Dim oSh As Worksheet
Dim i As Long, j As Long
Dim pLastRow As Long
Dim pMod As Long

Set oSh = Sheets("Sheet1") 'Sheet1には実際使っているシート名を入れる。

With oSh
pLastRow = .Range("A" & .Rows.Count).End(xlUp).Row

For i = 1 To pLastRow
pMod = i Mod 3
Select Case pMod
Case 0
.Range("C" & i - 2) = .Range("A" & i)
Case 1
'そのまま
Case 2
.Range("B" & i - 1) = .Range("A" & i)
End Select
Next i

For i = pLastRow To 1 Step -1
If .Range("B" & i) = "" Then
.Rows(i & ":" & i).Delete
End If
Next i
End With

Set oSh = Nothing
End Sub

回答No.3

hige_082

こんな感じで

Sub test()
Dim i, ii, iii
Dim a
a = Range("a1", Cells(Rows.Count, 1).End(xlUp).Address)
Range("a1", Cells(Rows.Count, 1).End(xlUp).Address).ClearContents
iii = 1
For i = 1 To UBound(a, 1) / 3
For ii = 1 To 3
Cells(i, ii) = a(iii, 1)
iii = iii + 1
Next ii
Next i
End Sub

エラー処理、アレンジはご自分で

回答No.2

hisappy

Ａ列に並んでいるデータを単純に３つずつ並べなおすのと
データの内容によって移動先が変化するのかで
ＶＢＡの組み方もかわってきますが…

後者ならこんな感じでしょうか。
フローなコーディング版。

for(A1～Aの最終行)
　セル内容判定
　　１番：Ｂ列に移動。
　　２番：Ｃ列に移動。
　　３番：Ｄ列に移動。
end for
Ａ列削除。

実際にはＢ、Ｃ、Ｄの各列での現在行管理が必要です。
エラーなデータが存在していた場合の処理も
場合によっては必要でしょう。

お礼

ありがとうございます！
素人なのでもう少し詳しく教えていただけないでしょうか？
すいませんが宜しくお願い致します。

回答No.1

n-jun

B1 =INDIRECT("$A"&(ROW()-1)*3+(COLUMN()-1))
でＤ１まで右にフィルコピー。
Ｂ１～Ｄ１選択で下にフィルコピー。
Ｂ～Ｄ列コピー・Ｂ１をクリックし形式を選択して貼り付けで値を選択。

と言う方法もあります。

お礼

ありがとうございます！
素人なのでもう少し詳しく教えていただけないでしょうか？
すいませんが宜しくお願い致します。