行列の入れ替え

質問

次の処理を行うプログラムを書きたいのですが教えていただけないでしょうか？
(処理)
B列のあるセルの値が2000または2001の場合、当該行のc列からn列までのセルをコピーし、11行を挿入し、行列を入れ替えて貼り付ける。
この処理を繰り返したいです。

　　　　　　　　　　　　(処理前)
A　　B　　C　　D　　E　　F　　G 　　H　　I　　J　　L　　M　　N　　O
1　2000　　1　　2　　3　　4　　5　　6　　7　　8　　9　　10　　11　　12
2
3
4
5
6
7
8
9
10
11

(処理後)
A　　B　　C　　D　　E　　F　　G　　H　　I　　J　　L　　M　　N　　O
1　 2000　 1
2　　　　　　2
3　　　　　　3
4　　　　　　4
5　　　　　　5
6　　　　　　6
7　　　　　　7
8　　　　　　8
9　　　　　　9
10　　　　　10
11　　　　　11
12　　　　　12
13　　　　　13

よろしくお願いします。

回答No.4

ham_kamo · ベストアンサー

あれ、エラーが出ましたか。私のテストデータではエラーが出なかったのですが…。
新しいシートを作成し、ということなので、そのように直してみました。今表示しているシートの右に新しいシートを挿入し、そちらへ転記するようにしています。
これで試してみていただけないでしょうか。

Sub Sample()
　Dim i As Integer, j As Integer
　Dim WS1 As Worksheet, WS2 As Worksheet
　i = 1: j = 1
　Application.ScreenUpdating = False
　Set WS1 = ActiveSheet
　Set WS2 = Worksheets.Add(After:=WS1)
　For i = 1 To WS1.Cells(Rows.Count, "B").End(xlUp).Row
　　WS1.Rows(i).Copy WS2.Rows(j)
　　If WS1.Cells(i, "B").Value = 2000 Or WS1.Cells(i, "B").Value = 2001 Then
　　　WS2.Cells(j, "C").Resize(1, 12).ClearContents
　　　WS1.Cells(i, "C").Resize(1, 12).Copy
　　　WS2.Cells(j, "C").PasteSpecial Transpose:=True
　　　j = j + 12
　　Else
　　　j = j + 1
　　End If
　Next
　Application.CutCopyMode = False
　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。おかげで解決できました。