縦横 横 横

Ａ列　Ｂ列 C列　D列
1　　Ａ　　Ｂ　1 2
2　　Ｃ　　Ｄ 3 4
3　　Ｅ　　Ｆ 5 6
これを
Ａ列　Ｂ列 C列　D列
1　Ａ 1 2
2　Ｂ
3　Ｃ 3 4
4　Ｄ
5　Ｅ 5 6
6　Ｆ
とやることは可能でしょぅか？
Sub t()
Dim r1, r2 As Range
Set r2 = Worksheets(2).Range("a1")
With Worksheets("sheet1")
For Each r1 In .Range("a3", .Cells(Rows.Count, 1).End(xlUp))
r2.Resize(4).Value = Application.Transpose(r1.Resize(, 4).Value)
Set r2 = r2.Offset(2)
r2.Offset(-2, 1).Value = r2.Resize(r1, 4).Value
Next
End With
End Sub
このｺｰﾄﾞはいつもこのサイトから教えていただいている方から
頂戴致しました。すこし付け加えてもなかなかいかないです。
わかる方いましたらお願い致します。
付け加えた部分
r2.Offset(-2, 1).Value = r2.Resize(r1, 4).Value

質問者からの補足コメント

• 

  For Each r1 In .Range("a3", .Cells(Rows.Count, 1).End(xlUp))
  r2.Resize(4).Value = Application.Transpose(r1.Resize(, 4).Value)
  Set r2 = r2.Offset(2)
  r2.Offset(-2, 1).Value = r2.offset(r1, 3).Value　　①
  r2.Offset(-2, 1).Value = r2.offset(r1, 4).Value　　②
  ①②にを一つにまとめることは可能でしょうか

    補足日時：2018/07/22 07:23

No.3 ベストアンサー 回答者： めぐみん_ 回答日時： 2018/07/22 07:49

No.1です。

一番左の数字は行数だったようですね。
必ず2個ずつずらしていくのなら、

Sub try()
Dim r1 As Range
Dim r2 As Range

Set r1 = Worksheets("Sheet1").Range("A1")
Set r2 = Worksheets("Sheet2").Range("A1")

Do Until r1.Value = ""

r2.Resize(2).Value = Application.Transpose(r1.Resize(, 2).Value)
r2.Offset(, 1).Resize(, 2).Value = r1.Offset(, 2).Resize(, 2).Value

Set r1 = r1.Offset(1)
Set r2 = r2.Offset(2)

Loop

Set r1 = Nothing
Set r2 = Nothing
End Sub

一例です。

この回答へのお礼

Set r1 = r1.Offset(1)
Set r2 = r2.Offset(2)
　この部分がわかりませんでした
あとは思い通りです。有難うございました。

お礼日時：2018/07/22 21:32

No.4 回答者： めぐみん_ 回答日時： 2018/07/22 07:53

No.3です。

シート1の開始位置がA3なら

＞Set r1 = Worksheets("Sheet1").Range("A1")

を

Set r1 = Worksheets("Sheet1").Range("A3")

ですかね。

No.2 回答者： siffon9 回答日時： 2018/07/22 07:19

ご提示のデータがA1セルから始まっているのに

> For Each r1 In .Range("a3",
ここがA3から始まっているのは意味不明です。

あと、Application.Transposeはサンプルのような小規模なデータでは使用しないと思います。



やりたいことは、B列のデータだけは、次の行のA列にコピーしたいってことですよね？


Sub t2()
　　Dim row1 As Long
　　Dim row2 As Long
　　Dim col As Long
　　Dim sh1 As Worksheet, sh2 As Worksheet
　　
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　row1 = 1 'シート1の作業対象行
　　row2 = 1 'シート2の作業対象行
　　col = 1 '作業対象列
　　
　　' シート1のA列のデータがある間、対象行を下げて繰り返す
　　Do While sh1.Cells(row1, col).Value <> ""
　　　　'sh1の列によってコピー先をかえる
　　　　Select Case col
　　　　Case 1: 'A列
　　　　　　sh2.Cells(row2, col).Value = sh1.Cells(row1, col).Value
　　　　Case 2: 'B列
　　　　　　sh2.Cells(row2 + 1, 1).Value = sh1.Cells(row1, col).Value
　　　　Case Else: 'C列以降
　　　　　　sh2.Cells(row2, col - 1).Value = sh1.Cells(row1, col).Value
　　　　End Select
　　
　　　　' 次の列
　　　　col = col + 1
　　　　' その行のデータが無くなったら次の行の処理にうつる
　　　　If sh1.Cells(row1, col).Value = "" Then
　　　　　　row1 = row1 + 1
　　　　　　row2 = row2 + 2
　　　　　　col = 1
　　　　End If
　　Loop
End Sub

No.1 回答者： めぐみん_ 回答日時： 2018/07/22 04:29

実行前が4列である事は何となく分かるのですが実行後も4列になると言う事は、どの列にどの値が入るのか？が少しわかりにくいかな。

あとＡ列は単純に１から始まるカウント数なのかどうかとか。

シート内容を文字で表すのならセルの区切りを例えばアンダーライン（＿）にしてみるとか、シートの画像を添付した方が良かったかもと思います。