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.

 

[parankush]

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

How can add this VBA code into function kindly help me with that

 

[DanteAmor]

into function kindly

What do you mean by function?

HOW TO INSTALL MACROs
------------------------------------
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (Transpose_2) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

 

[JoeMo]

It is showing an error.
View attachment 16008

After Clicking in Debug it is showing
View attachment 16009

Please Help

Don't know why you are getting that error. Can you post the raw data using XL2BB so I can see the layout?

 

[parankush]

T

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

The code you gave worked. I have copied it in a module and saved It as Macro-Enabled Worksheet. I Paste the Data in sheet 1 and Get the output in sheet 2. But after using it for some 15-20 times. It gives error "Out of Memory".

 

[DanteAmor]

It gives error "Out of Memory".

You could comment the following:

1. In which line of the macro does the error send you?
2. Are the data the same or are they increasing?
3. How many rows with data do you have?
4. How many columns with data do you have?

After answering the above, you could try the following:

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
  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
End Sub

 

[parankush]

You could comment the following:

1. In which line of the macro does the error send you?
2. Are the data the same or are they increasing?
3. How many rows with data do you have?
4. How many columns with data do you have?

After answering the above, you could try the following:

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
  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
End Sub

1.)In 4th line"(a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)).Value2)
2.)They are both Increasing or decreasing.
3.) Not more than Row 1,00,000.
4.)Not more than column DZ.

 

[DanteAmor]

Also try the following:

Sub Transpose_2()
  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 Sheets("Sheet1")
    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
End Sub

 

[DanteAmor]

Tell me what appears in the msgbox

Not more than Row 1,00,000.

100,000 or 1,000,000(one million)?

 

[parankush]

Tell me what appears in the msgbox



100,000 or 1,000,000(one million)?

1 Lakh.

I will try all the codes. And if I find any error I will update the same.

 

[DanteAmor]

I have no problems with 100,000 and DZ column.
Run the macro in post #17 again and tell me it appears in the msgbox.