別シートにある表のデータを行列を入れ替えてコピペしたい

Question

実現したいこと

• シート1にある表のデータを行列を入れ替えてシート2にコピペしたい

前提

下記のような表1をマクロを使用して表2の形にして貼付されるようにしたいと考えております。

・表1

番号	データ1	データ2	データ3	データ4
1	○○○○	■■■■	△△△△	××××
2	○○○○	■■■■	△△△△	××××
3	○○○○	■■■■	△△△△	××××
4	○○○○	■■■■	△△△△	××××
5	○○○○	■■■■	△△△△	××××
6	○○○○	■■■■	△△△△	××××

・表2

列1	列2
○○○○	■■■■
	△△△△
	××××
○○○○	■■■■
	△△△△
	××××
○○○○	■■■■
	△△△△
	××××
○○○○	■■■■
	△△△△
	××××

発生している問題・エラーメッセージ

行列を入れ替えて貼り付けるコードは下記を使用すればよいということはわかったのですが、2列に分けて、なおかつ空白セルを挟む場合のコードが作成できず悩んでおります。

＜コード1＞

Sub Macro12()
Sheets("Sheet1").Range("B1:E4").Copy
Sheets("Sheet2").Range("A1").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
　　Application.CutCopyMode = False

End Sub

また、以前こちらでお世話になった際に下記のコードをご教示いただき、使用していたのですが、転記元データが4行あるのに対して転記先のデータでは2行しか表示されない等といった現象が起きてしまいました。

＜コード2＞

    
    Dim wsForm As Worksheet '転記元シート
    Dim wsPost As Worksheet '転記先シート
    
    'ここは自分で書き換えてください----------------------------------------------
    Set wsForm = ThisWorkbook.Sheets("変換前")
    Set wsPost = ThisWorkbook.Sheets("変換後")
    
    Const START_ROW As Long = 2 'データ開始行(タイトル除く)
    Const DATA_COLUMN As Long = 2 'データは何列目にあるか(今回は例としてA列)
    
    '----------------------------------------------------------------------------
    'そのほかの項目
    Dim end_row As Long 'データ最終行
    end_row = wsForm.Cells(Rows.Count, DATA_COLUMN + 4).End(xlUp).Row '最終行取得(空白を加味して所有者行を基準に設定)※数値不定の為const使用不可
    
    Dim blankCnt As Long '空白行数計算用
    Dim rowCnt As Long
    Dim colCnt As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For rowCnt = START_ROW To end_row
        blankCnt = 0
        
        '空白行数カウント
        Do While (wsForm.Cells(rowCnt + blankCnt + 1, DATA_COLUMN).Value = "") '次の行が空白じゃなくなるまでループ
            '最終行に達してたら終了
            If rowCnt + blankCnt >= end_row Then Exit Do
            
            blankCnt = blankCnt + 1
        Loop
        
        Call データ転記(wsForm, wsPost, wsForm.Cells(rowCnt, DATA_COLUMN), blankCnt)
        
        '邪道ではあるが、空白行数分ループを進める(処理済みなので)
        rowCnt = rowCnt + blankCnt
    Next rowCnt
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Private Sub データ転記(form As Worksheet, post As Worksheet, rngData As Range, ByVal cnt As Long)
    'データ転記関数
    'form   :転記元シート
    'post   :転記先シート
    'rngData:転記するデータの先頭セル
    'cnt    :空白行数(forが0スタートなので処理行数-1であることに注意)
    
    Dim rng As Range
    Dim i As Long
    Dim col As Long
    '転記先のA列に転記していく場合
    '最後尾セル取得
    Set rng = post.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    
    '行→列の順番でループ(項目1のみ処理を変更する)----------------------------------------------------------------
    For col = 0 To 5
        
        '3列目なら転記位置が違うので処理を変える(基本部分は同じ)
        If col = 3 Then
            Set rng = rng.Offset(-(cnt + 1), 0) '行数を項目1の行数分戻す
            For i = 0 To cnt
                If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了
                
                rng.Offset(0, 1).Value = rngData.Offset(i, col).Value
                Set rng = rng.Offset(1, 0) '一列下に移動
            Next i
        Else
            For i = 0 To cnt
                If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了
                
                rng.Value = rngData.Offset(i, col).Value
                Set rng = rng.Offset(1, 0) '一列下に移動
            Next i
        End If
    Next col
    
    '処理終わり----------------------------------
    Set rng = Nothing
    
    
End Sub

試したこと

ループの数値を変更し、転記位置の数値の変更もしたのですが、マクロが動かなくなってしまったり、本来転記されるべきデータが転記されなくなってしまったりと、探れば探るほど原因がわからなくなってしまいました。

私の知識不足で大変申し訳ないのですが、今一度皆様のお力添えをお願いしたく思います。
また、可能でしたら、＜コード2＞について詳細をご教示いただけますと幸いです。
何卒宜しくお願い致します。

Comments

[pig_vba]

前回質問（コード添付元）の回答者です。そのコードと今回の質問内容では前提条件が違う（前回のほうが条件が複雑）なのでそのまま流用するのは不可能だと思います。
多分
end_row = wsForm.Cells(Rows.Count, DATA_COLUMN + 4).End(xlUp).Row←二行しか表示されない主原因
→end_row = wsForm.Cells(Rows.Count, 1).End(xlUp).Row
とデータ転記内の
If col = 3 Then
Set rng = rng.Offset(-(cnt + 1), 0) '行数を項目1の行数分戻す
For i = 0 To cnt
If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了

rng.Offset(0, 1).Value = rngData.Offset(i, col).Value
Set rng = rng.Offset(1, 0) '一列下に移動
Next i
Else
↑を全部消せば同じような動きにはなるかもですが、今回の要件に入らない処理だらけなので作り直した方が早いですね

[shibakoppe]

先日は大変お世話になりました。
丁寧にご対応いただいたにもかかわらず、理解が及んでおらず申し訳ございません…。
ご案内いただき、誠にありがとうございました。

Answer 1

レイアウトが補足要求の補足通りとすると、
以下のようになります。
シート名は、表1が変換前、表２が変換後とします。

Option Explicit
Public Sub 並べ替え()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim maxrow As Long
    Dim row1 As Long
    Dim row2 As Long
    Set ws1 = Worksheets("変換前")
    Set ws2 = Worksheets("変換後")
    maxrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row    '最大行取得
    row2 = 1
    For row1 = 2 To maxrow
        ws2.Cells(row2, "A").Value = ws1.Cells(row1, "B").Value
        ws2.Cells(row2, "B").Value = ws1.Cells(row1, "C").Value
        row2 = row2 + 1
        ws2.Cells(row2, "B").Value = ws1.Cells(row1, "D").Value
        row2 = row2 + 1
        ws2.Cells(row2, "B").Value = ws1.Cells(row1, "E").Value
        row2 = row2 + 1
    Next
End Sub

Comments

[shibakoppe]

この度はご教示いただきまして誠にありがとうございました！
おかげで無事動かすことができました！
お二方にBAを送らせていただきたい気持ちでいっぱいですが、お一人しか選べないため先にご覧いただいたtatsu99様のご回答をBAとさせていただきました。
改めまして、この度は大変お世話になりました！

Answer 2

一応、二種類の手法を提示しておきます。

Sub transposeMacro()
    
    Dim wsForm As Worksheet '転記元シート
    Dim rngCpy As Range     '転記したいセル
    
    
    Dim wsPost As Worksheet '転記先シート
    Dim rngPst As Range     '転記先先頭セル
    
    
    Set wsForm = ThisWorkbook.Sheets("Sheet1")
    Set wsPost = ThisWorkbook.Sheets("Sheet2")
    
    Const START_ROW As Long = 2 'データ開始行(タイトル除く)

    Dim end_row As Long 'データ最終行
    end_row = wsForm.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得(空白を加味して所有者行を基準に設定)※数値不定の為const使用不可
    
    Dim i As Long
        
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For i = START_ROW To end_row
        '転置するデータの先頭列(今回ならデータ２)を登録
        Set rngCpy = wsForm.Cells(i, 3)
        
        '転記位置をセット(データ列基準で最下行の1行下を指定)
        Set rngPst = wsPost.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
        
        
        'Sheet2に見出し行がないらしいので初回のみ位置調整（不要なら消してOK）
        If rngPst.Row = 2 Then Set rngPst = rngPst.Offset(-1, 0)
        
        
        'データ１をコピー
        rngPst.Offset(0, -1).Value = rngCpy.Offset(0, -1).Value
        
        
    'Transpose処理（どっちでも同じ動作。理解しやすい方を使用してください）-----------------------------------------------
    'Resize(1,3)は「(コピーする範囲を)1行３列に拡張」という意味です。データ2以降が4列以上あるなら3の部分を変更してください。


        '①worksheetFunction.Transposeを使う
        rngPst.Resize(3, 1).Value = WorksheetFunction.Transpose(rngCpy.Resize(1, 3).Value)
        
        
        '②Pastespecial transposeを使う
'        rngCpy.Resize(1, 3).Copy
'        rngPst.PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    '--------------------------------------------------------------------------------------------------------------------
        
    Next i
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub    

Comments

[shibakoppe]

ご教示いただきまして誠にありがとうございました！
説明まで付け加えていただき、本当に嬉しく思います！
お教えいただいた方法でも動かすことができました。
お二方にBAを送らせていただきたい気持ちでいっぱいですが、お一人しか選べないとのことなので、pig_vba様にはグッドを送らせていただきます。
改めまして、この度も大変お世話になりました！

Answer 3

回答ではありません。補足要求です。
表１のレイアウトは、どちらが正しいのでしょうか。（上ですか、それとも下ですか）（見出し行の確認です）

表２のレイアウトは、どちらが正しいのでしょうか。（上ですか、それとも下ですか）（見出し行の確認です）

Comments

[shibakoppe]

ご覧いただきありがとうございます。
表1には見出し行を設けていますが、表2は見出し行を設けていませんので、
tatsu99様にご提示いただいた画像ですと、表1は上、表2は下になります。
分かりにくい提示をしてしまい申し訳ございません。