VBA to transpose rows to columns by 'n' times

[anglais428]

Current data view:

A

B

C

D

E

<tbody>
</tbody>

Required data view:

A

B

C

D

E

A

B

C

D

E

<tbody>
</tbody>

This is taking 5 cells listed in rows and converting to 10 cells listed in columns (1 row).
Ideally the multiple of 2 (5 * 2 = 10) would be dynamic.

Thanks

 

[mumps]

This macro assumes the data you want to repeat is in column A starting in row 1. You will be prompted for the number of times you want the data repeated.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim lColumn As Long
    Dim response As Long
    response = InputBox("How many times do you want the data repeated?")
    Dim x As Long
    For x = 1 To response
        lColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
        Range("A1:A" & LastRow).Copy
        Cells(1, lColumn).PasteSpecial Transpose:=True
    Next x
    Columns(1).EntireColumn.Delete
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

Here is another macro for you to consider...

[table="width: 500"]
[tr]
	[td]Sub TransposeAndRepeat()
  Dim LastRow As Long, Response As Long, Arr As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Response = Application.InputBox("How many times do you want to you want the data repeated?", Type:=1)
  Arr = Split(Application.Rept(Join(Application.Transpose(Range("A1:A" & LastRow)), Chr(1)) & Chr(1), Response), Chr(1))
  Range("A1").Resize(, UBound(Arr) + 1) = Arr
  Range("A2:A" & LastRow).ClearContents
End Sub[/td]
[/tr]
[/table]

 

[johnmpl]

Hi, to all!

Another option could be:

Sub TransposeWithRep()    
    Dim n&, q&
    
    n = Application.InputBox(" Times to repeat? ", , 2): If n <= 0 Then Exit Sub
    With Range("A1").CurrentRegion.Columns(1)
        q = .Rows.Count: .Copy
    End With
    
    With Range("C1")
        .PasteSpecial xlPasteValues, , , True
        .Resize(, q).AutoFill .Resize(, q * n)
        .Select: Application.CutCopyMode = False
    End With
End Sub

 

[anglais428]

Thanks guys. These all work brilliantly.