ExcelでVBAを使用してループ内のセルを移動する

Question

1つのシート（行）からセルをコピーし、別のシートの行に貼り付けようとしています（基本的に転置します）。私はコードを書いたが、ペーストセルとpastespecialコマンドを回避することはできませんでした。コピーされたセルの長さは行ごとに異なるので、動的に選択して同じ方法で貼り付けるにはどうすればよいですか？現時点では、特定の長さを貼り付け、最後に空の行を削除することを考えています。以下のコードをご覧ください。誰かが私にインプットやアイデアを与えることができれば素晴らしいだろう。ありがとう!!

Sub Data_Sort_Test() 

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long 
Dim rng As Range, row As Range, rowd1 As Range, cell As Range 
Dim bidtype As String 
k = 1 
lastrow1 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).row 

For i = 1 To lastrow1 
bidtype = Sheets("Sheet2").Cells(i, "A").Value 

Sheets("Sheet1").Activate 
lastrow2 = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).row 

For j = 1 To lastrow2 
If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then 

Sheets("Sheet2").Activate 
Sheets("Sheet2").Range(Cells(i, "B"), Cells(i, "K")).Copy 
Sheets("Sheet3").Activate 
Sheets("Sheet3").Range(Cells(j, "C"), Cells(j, "L")).Select 
ActiveSheet.Paste 'Special Transpose:=True 
'k = k + 1 
End If 
Next j 
Application.CutCopyMode = False 
Next i 

End Sub 

Answer 1

これを試してみて、それが動作するかどうか私に教えて：

Sub Data_Sort_Test() 

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long 
Dim rng As Range, row As Range, rowd1 As Range, cell As Range 
Dim bidtype As String 
Dim tWs As Worksheet 

Set tWs = Sheets("Sheet3") 
With Sheets("Sheet2") 
k = 1 
lastrow1 = .Range("A" & .Rows.Count).End(xlUp).row 

For i = 1 To lastrow1 
    bidtype = .Cells(i, "A").Value 

    lastrow2 = Sheets("Sheet1").Range("B" & Sheets("Sheet1").Rows.Count).End(xlUp).row 
    For j = 1 To lastrow2 
     If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then 

      .Range(.Cells(i, "B"), .Cells(i, "K")).Copy 

      tWs.Range(tWs.Cells(j, "C"), tWs.Cells(j, "L")).PasteSpecial 'Transpose:=True 

     End If 
    Next j 
    Application.CutCopyMode = False 
Next i 
End with 
End Sub 

私はすべての.Selectと.Activateを取り出して、直接、適切な親子関係でそれらを置き換えます。これにより、コードが高速化され、読みやすくなります。

Answer 2

@Scott私は転置を入れましたが、何とか行数に問題があります。どう思いますか？？

Sub Data_Sort_Test() 

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long 
Dim rng As Range, row As Range, rowd1 As Range, cell As Range 
Dim bidtype As String 
Dim tWs As Worksheet 

Set tWs = Sheets("Sheet3") 
With Sheets("Sheet2") 
k = 1 
lastrow1 = .Range("A" & .Rows.Count).End(xlUp).row 

For i = 1 To lastrow1 
bidtype = .Cells(i, "A").Value 

lastrow2 = Sheets("Sheet1").Range("B" & **strong text**Sheets("Sheet1").Rows.Count).End(xlUp).row 
For j = 1 To lastrow2 
    If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then 

     .Range(.Cells(i, "B"), .Cells(i, "K")).Copy 

     tWs.Range("B" & Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True 
     tWs.Range("B1").Delete shift:=xlUp 

    End If 
Next j 
Application.CutCopyMode = False 
Next i 
End With 
End Sub