Sub Transpose_5()
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long
Dim lr As Long, lc As Long
'
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
With Sheets("Sheet1")
a = Range("A1:A2").Value2
b = Range("A1:A2").Value2
Erase a, b
lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
lc = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
a = .Range("A1", .Cells(lr, lc)).Value2
End With
MsgBox "Rows : " & UBound(a, 1) & " Cols: " & UBound(a, 2) & vbCr & "Press Enter to continue"
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
'
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
If a(i, j) <> "" Then
k = k + 1
b(k, 1) = a(i, j)
End If
Next
Next
Sheets("Sheet2").Range("A1").Resize(k).Value = b
Erase a, b
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
End Sub