Transpose multiple rows and columns into one column with ignoring blanks

[parankush]

i want to Transpose multiple rows and columns into one column with ignoring blanks. I have a large amount of data. But i can provide with a sample.Is there any VBA code i can use for it.

 

[DanteAmor]

Hi and welcome to MrExcel

You could provide the same example but the result you want.
Use XL2BB tool, look at my signature.

 

[alansidman]

Is this what you are looking for? If not, provide as Dante suggested your expected output. Use XL2BB

Book1
	A	B	C
1	Month	Attribute	Value
2	Jan	B	6
3	Jan	C	11
4	Feb	A	3
5	Feb	B	9
6	Feb	C	15
7		A	5
8		C	5
9	Apr	A	7
10	Apr	B	12
11	Apr	C	4.333333
12	May	A	9
13	May	B	15
14	May	C	1.333333
15	Jun	A	11
16	Jun	C	-1.66667
Sheet2

 

[parankush]

Yeah...! Sorry for the incomplete data.
So ,I want this Input data.

Converted like this.

 

[JoeMo]

Assuming column F is free to write the converted data to, and that the data starts in A1 (Month) and there are no completely empty rows in it, try this:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    Vrw = R.Rows(i).Value
    Vout = Application.Transpose(Vrw)
    NxRw = IIf(IsEmpty(Range("F1")), 1, Range("F" & Rows.Count).End(xlUp).Row + 1)
    Range("F" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
Next i
With Columns("F")
    On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    On Error GoTo 0
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub

 

[parankush]

Assuming column F is free to write the converted data to, and that the data starts in A1 (Month) and there are no completely empty rows in it, try this:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    Vrw = R.Rows(i).Value
    Vout = Application.Transpose(Vrw)
    NxRw = IIf(IsEmpty(Range("F1")), 1, Range("F" & Rows.Count).End(xlUp).Row + 1)
    Range("F" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
Next i
With Columns("F")
    On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    On Error GoTo 0
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub

No No. The data I have is very large. so the data is in sheet one and I want the result in sheet 2. So I will get the result from the above code??

 

[JoeMo]

No No. The data I have is very large. so the data is in sheet one and I want the result in sheet 2. So I will get the result from the above code??

OK, then assuming Sheet2 already exists and has column A empty to receive the converted data, try running this when the raw data sheet is the activesheet:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    Vrw = R.Rows(i).Value
    Vout = Application.Transpose(Vrw)
    NxRw = IIf(IsEmpty(Sheets("Sheet2").Range("A1")), 1, Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
    Sheets("Sheet2").Range("A" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
Next i
With Sheets("Sheet2").Columns("A")
    On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    On Error GoTo 0
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub

 

[parankush]

OK, then assuming Sheet2 already exists and has column A empty to receive the converted data, try running this when the raw data sheet is the activesheet:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    Vrw = R.Rows(i).Value
    Vout = Application.Transpose(Vrw)
    NxRw = IIf(IsEmpty(Sheets("Sheet2").Range("A1")), 1, Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
    Sheets("Sheet2").Range("A" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
Next i
With Sheets("Sheet2").Columns("A")
    On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    On Error GoTo 0
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub

It is showing an error.

After Clicking in Debug it is showing

Please Help

 

[DanteAmor]

Here are a couple of macros for your consideration.
Assume that your data is on sheet1 starting in cell A1, the results on sheet2.

Sub Transpose_1()
  Dim c As Range
  Application.ScreenUpdating = False
  For Each c In Sheets("Sheet1").Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants)
    Sheets("Sheet2").Range("A" & Rows.Count).End(3)(2).Value = c.Value
  Next
End Sub

The following macro is longer, but it is faster.

Sub Transpose_2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)).Value2
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
  For j = 1 To UBound(a, 2)
    For i = 1 To UBound(a, 1)
      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
End Sub

 

[DanteAmor]

A detail emerged, use this code:

Sub Transpose_2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)).Value2
  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
End Sub