VBA excel transponse many rows into columns with different size

Question

I have 88213 rows of data which range from 11 to 21 columns.

Traditionally copying and pasting the data is not working.

I have read many scripts here but noone suggests the very common script of transponsing rows to columns (or columns to rows if you want).

Can someone help me how to do so?

I have tried this but the loop is not working:

Sub Transponse()

    Dim wrkSht As Worksheet
    Dim lLastCol As Long
    Dim lLastRow As Long
    Dim i As Long

    'Work through each sheet in the workbook.
    'For Each wrkSht In ThisWorkbook.Worksheets
     For j = 1 To lLastRow
        'Find the last column on the sheet.
        lLastCol = LastCell(wrkSht).Column

        'Work through each column on the sheet.
        For i = 1 To lLastCol

            'Find the last row for each column.
            lLastRow = LastCell(wrkSht, i).Row

            'Remove the duplicates.
            With wrkSht
                .Range(.Cells(1, i), .Cells(j, i)).Select
                 Selection.Copy
                 Sheets("Tabelle2").Select
                 Range(.Cells(j, 1)).Select
                 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                 False, Transpose:=True
            End With
        Next i

    Next j
    'Next wrkSht

    Range("A1:K1").Select
    Selection.Copy
    Sheets("Tabelle2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

End Sub

'This function will return a reference to the last cell in either the sheet, or specified column on the sheet.
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Answer 1

I think something like this should work (supposing your data is on sheet(1), and want to copy everything to sheet(2)):

Option Explicit
Sub test()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    i = 1
    While Sheets(1).Cells(1, i).Value <> ""
        j = 1
        While Sheets(1).Cells(j, i).Value <> ""
            Sheets(2).Cells(i, j) = Sheets(1).Cells(j, i)
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

another version that continues on the following sheet.

1. Be aware, this doesn't create sheets, so you need to have the required amount of sheets before you let it run.

2. it doesn't repeat your header on the sheets

3. the two outcommented lines are for test purposes

   Option Explicit Sub test() Dim i As Double Dim j As Double Dim k As Double

   i = 1
   k = 2
   While Sheets(1).Cells(1, i).Value <> ""
       j = 1
       While Sheets(1).Cells(j + (k - 2) * 16384, i) <> ""
           If j <= (k - 1) * 16384 Then
               'Sheets(k).Cells(i, j).Select
               Sheets(k).Cells(i, j) = Sheets(1).Cells(j + (k - 2) * 16384, i)
           Else
               j = 0
               k = k + 1
               'Sheets(k).Activate
           End If
           j = j + 1
       Wend
       k = 2
       i = i + 1
   Wend
   End Sub
   

and a small thing to clean your duplicates in your rows (with 82000 rows it won't be that quick):

Sub Eraser()
    Dim i As Double
    Dim j As Double
    Dim k As Double
    i = 1
    While Sheets(1).Cells(i, 1).Value <> ""
        j = 1
        While Sheets(1).Cells(i, j).Value <> ""
            k = j + 1
            While Sheets(1).Cells(i, k).Value <> ""
                If Sheets(1).Cells(i, j).Value = Sheets(1).Cells(i, k).Value Then
                    Sheets(1).Cells(i, k).Delete Shift:=xlToLeft
                    k = k - 1
                End If
                k = k + 1
            Wend
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

Answer 2

This should do the trick (it creates a new sheet for each sheet you transpose) :

Sub Transpose_All_Sheets()
    Dim tB As Workbook
    Dim wS As Worksheet
    Dim DestWS As Worksheet
    Dim LastRow As Double
    Dim EndCol As Integer
    Dim i As Long
    Dim j As Long

    Set tB = ThisWorkbook

    For Each wS In tB.Sheets
        If Left(wS.Name, 2) <> "T_" Then
            Set DestWS = tB.Sheets.Add
            DestWS.Name = "T_" & wS.Name
            LastRow = LastRow_1(wS)
            For i = 1 To LastRow
                EndCol = wS.Cells(i, wS.Columns.Count).End(xlToLeft).Column
                wS.Range(wS.Cells(i, 1), wS.Cells(i, EndCol)).Copy DestWS.Cells(1, i)
            Next i
        Else
        End If
    Next wS

MsgBox "done"
End Sub

With :

Public Function LastRow_1(wS As Worksheet) As Double
    With wS
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            LastRow_1 = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        Else
            LastRow_1 = 1
        End If
    End With
End Function

Answer 3

There is a built in operation to handled this in Excel... On a side note, you should probably be using a database with this many records.

In fact, I need to update my answer. Excel will only support 16384 columns. So you can not flip 88213 rows into column space.

Here is the Microsoft spec on Excel from 2007 through 2016... https://support.office.com/en-us/article/excel-specifications-and-limits-1672b34d-7043-467e-8e27-269d656771c3

You can also search for Transpose Rows in the Excel help. Here is the content...

Here’s how:

1.Select the range of data you want to rearrange, including any row or column labels, and press Ctrl+C.


Note:  Make sure you copy the data to do this. Using the Cut command or Ctrl+X won’t work.


2.Right-click the first cell where you want to paste the data, and pick Transpose Tranpose button image .

Pick a spot in the worksheet that has enough room to paste your data. The data you copied will overwrite any data that’s already there.

Paste Options menu 


3.After rotating the data successfully, you can delete the original data.



Tips for transposing your data

If your data includes formulas, Excel automatically updates them to match the new placement. Verify these formulas use absolute references—if they don’t, you can switch between relative, absolute, and mixed references before you rotate the data.


If your data is in an Excel table, the Transpose feature won’t be available. You can convert the table to a range first, or you can use the TRANSPOSE function to rotate the rows and columns.


If you want to rotate your data frequently to view it from different angles, consider creating a PivotTable so you can quickly pivot your data by dragging fields from the Rows area to the Columns area (or vice versa) in the PivotTable Field List.