VBA Transpose Every Three Row and Every Three Column.

[Sami_Noa]

Hell every body. I got this code for transpose a column to many rows

Application.ScreenUpdating = False
On Error Resume Next
Dim i&, z&, x&, y1&

y1 = InputBox("Choose the number of columns")
y2 = InputBox("Choose the number of rows")
i = Cells(Rows.Count, 1).End(xlUp).Row
z = 2: x = 2
Range("B2:K" & i) = ""
While z <= i

Range("b" & x).Resize(, y1) = _
WorksheetFunction.Transpose(Range("a" & z).Resize(y1))
z = z + y1: x = x + 1
Wend
Application.ScreenUpdating = True

I need to make this code work in this way i supposed the number of columns 3 it is possible to be another number :
First Case
original column
1
2
3
4
5
6
7
8
9
transposed range
1 4 7
2 5 8
3 7 9

Second case
original range
1 11 111
2 22 222
3 33 333
4 44 444
5 55 555

transposed range
1 2 3
11 22 33
111 222 333
4 5
44 55
444 555
thanks in advance

 

[Rick Rothstein]

Hell every body. I got this code for transpose a column to many rows

I think the problem you are having code-wise is due to the fact that you are "transposing" the two ranges differently. In the first case (for a single column of values), you are simply grabbing groups of three and placing them next to each other whereas in the second case (for a two-dimensional range of values), you are physically transposing the groups of three as you grab them. Given the use of the word "transpose", and to do it like you did for the second case, I would have expected the single column case to have look like this...

1 2 3
4 5 6
7 8 9

So, two questions...

1) Is what you show for the two cases exactly what you want?

2) What would the transposition for the following look like?

1	11	111	1111
2	22	222	2222
3	33	333	3333
4	44	444	4444
5	55	555	5555

 

[Sami_Noa]

hello
the problem was i need to solve it. I get the names of invitees in a sheet of excel with one column contents all the names and I must print them on stickers that on A4 Page. but sometimes I get the names of the invitees in a table with 3 or 4 or 5 columns contents the information of each invitee like title - university - position ..
I must put them in the same badge . if there is a way to make the first case I can manage this case by uniting the columns in one with suitable order by vba.so the first answer it's exactly what I need.

the second question
1 2 3 ...
11 22 33 ...
111 222 333 ...
1111 2222 3333 ...
.........
I alter the code and i got a part of the solution

Application.ScreenUpdating = False
On Error Resume Next
Dim i&, z&, x&, y1&


y1 = InputBox("Choose the number of columns")
y2 = InputBox("Choose the number of rows")
i = Cells(Rows.Count, 1).End(xlUp).Row
z = 2: x = 2
Range("B2:K" & i) = ""
While z <= i

Range("b" & x).Resize(, y1) = _
WorksheetFunction.Transpose(Range("a" & z).Resize(y1))

[COLOR=#ff0000]z = z + y1 * y1: x = x + y1[/COLOR][COLOR=#000000]
Wend[/COLOR]

that can make that

1 2 3
- - -
- - -
10 11 12
- - -
- - -
19 20 21

but I couldn't make this code apply the transposing on the rest rows.


thank you very much.

 

[Sami_Noa]

the i got this code after editing old one can't give me what i want but i ask if can do what i need with some magical change!

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18


1 4 7
2 5 8
3 6 9
10 13 16
11 14 17
12 15 18

 

[shg]

Perhaps ...

Sub Sami()
  Const m           As Long = 3
  Dim rInp          As Range
  Dim avInp         As Variant
  Dim avOut         As Variant
  Dim i             As Long
  Dim ii            As Long
  Dim j             As Long
  Dim jj            As Long

  Set rInp = ActiveCell.CurrentRegion
  With rInp
    Set rInp = .Resize((.Rows.Count \ m) * m, (.Columns.Count \ m) * m)
  End With

  On Error Resume Next
  Set rInp = Application.InputBox(Prompt:="Select a range", _
                                  Default:=rInp.Address, _
                                  Type:=8)
  If Err.Number Then Exit Sub
  On Error GoTo 0

  With rInp
    Set rInp = .Resize((.Rows.Count \ m) * m, (.Columns.Count \ m) * m)
  End With

  With rInp
    avInp = .Value2
    ReDim avOut(1 To .Rows.Count, 1 To .Columns.Count)

    For i = 1 To .Rows.Count Step m
      For j = 1 To .Columns.Count Step m
        For ii = 0 To m - 1
          For jj = 0 To m - 1
            avOut(i + jj, j + ii) = avInp(i + ii, j + jj)
          Next jj
        Next ii
      Next j
    Next i

    .Select
    rInp.Value2 = avOut
  End With
End Sub

Select any cell in the range of interest and run.

 

[shg]

A little clean-up:

Sub Sami()
  Const m           As Long = 3
  Dim rInp          As Range
  Dim avInp         As Variant
  Dim avOut         As Variant
  Dim i             As Long
  Dim ii            As Long
  Dim j             As Long
  Dim jj            As Long

  Set rInp = ActiveCell.CurrentRegion
  If Not ShrinkToMultiple(rInp, m) Then Set rInp = rInp.Resize(m, m)

  On Error Resume Next
  Set rInp = Application.InputBox(Title:="Hey, Sami!", _
                                  Prompt:="Select a range:", _
                                  Default:=rInp.Address, _
                                  Type:=8)
  If Err.Number Then Exit Sub
  On Error GoTo 0

  If Not ShrinkToMultiple(rInp, m) Then
    MsgBox Title:="Hey, Sami!", _
           Prompt:=Replace("Input range must be at least @ rows × @ columns", "@", m)
    Exit Sub
  End If

  With rInp
    avInp = .Value2
    ReDim avOut(1 To .Rows.Count, 1 To .Columns.Count)

    For i = 1 To .Rows.Count Step m
      For j = 1 To .Columns.Count Step m
        For ii = 0 To m - 1
          For jj = 0 To m - 1
            avOut(i + jj, j + ii) = avInp(i + ii, j + jj)
          Next jj
        Next ii
      Next j
    Next i

    .Select
    rInp.Value2 = avOut
  End With
End Sub

Function ShrinkToMultiple(r As Range, m As Long) As Boolean
  ' returns True and range r reduced (if necessary) to have an
  ' multiple of m rows and m columns

  Dim nRow          As Long
  Dim nCol          As Long

  With r
    nRow = (.Rows.Count \ m) * m
    nCol = (.Columns.Count \ m) * m

    If nRow > 0 And nRow + .Row - 1 <= .Worksheet.Rows.Count + 1 And _
       nCol > 0 And nCol + .Column - 1 <= .Worksheet.Columns.Count + 1 Then
      Set r = r.Resize(nRow, nCol)
      ShrinkToMultiple = True
    End If
  End With
End Function

 

[Sami_Noa]

THANKS A LOT
I GOT WHAT I NEED EXACTLY BY THIS:

Application.ScreenUpdating = False
On Error Resume Next
Dim i&, z&, x&, y1&

y1 = InputBox("Choose the number of columns")
y2 = InputBox("Choose the number of rows")
i = Cells(Rows.Count, 1).End(xlUp).Row

z = 2: x = 2
Range("D2:K" & i) = ""
While z <= i
Range("d" & x).Resize(, y1) = _
WorksheetFunction.Transpose(Range("a" & z).Resize(y1))
z = z + y1: x = x + 3
Wend

z = 2: x = 3
While z <= i
Range("d" & x).Resize(, y1) = _
WorksheetFunction.Transpose(Range("B" & z).Resize(y1))
z = z + y1: x = x + 3
Wend

z = 2: x = 4
While z <= i
Range("d" & x).Resize(, y1) = _
WorksheetFunction.Transpose(Range("C" & z).Resize(y1))
z = z + y1: x = x + 3
Wend

 

[shg]

Good job!