Sub a() Set S1 = Sheets("シート1") Set S2 = Sheets("シート2") With S1 R_max = .UsedRange.Rows.Count C_max = .UsedRange.Columns.Count R_dest = 2 For c = 1 To C_max Step 3 For r = 2 To R_max If .Cells(r, c) <> "" Then S2.Cells(R_dest, 1) = .Cells(r, c) S2.Cells(R_dest, 2) = .Cells(r, c + 1) S2.Cells(R_dest, 3) = .Cells(r, c + 2) R_dest = R_dest + 1 End If Next Next End With End Sub