How to convert multiple rows into a single row

mcva

New Member
Joined
Apr 20, 2020
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hello, I´m beginning to learn vba, and I just can´t solve this one. If someone can help me...thank you
I have several excel worksheets that approximatly 7336 rows filed with groups of numbers with different column and row length.
The output I need is below. Basically inside each group all rows are aligned.
I have used without success the code below. I just can´t make it go trough all the groups
Thank you


Excel_project.jpg


VBA Code:
[CODE=vba]Sub convertMultipleRowsToOneRow()
    Set myRange = Application.InputBox("select one range that you want to convert:", "", Type:=8)
    Set dRang = Application.InputBox("Select one Cell to place data:", "", Type:=8)
    rowNum = myRange.Rows.Count
    colNum = myRange.Columns.Count
    For i = 1 To rowNum
        myRange.Rows(i).Copy dRang
        Set dRang = dRang.Offset(0, colNum + 0)
    Next
End Sub
[/CODE]
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
739
Office Version
  1. 365
Platform
  1. Windows
Try the updated below code

VBA Code:
Sub PrepareList()

Dim a As Variant, b As Variant, r&, c&
a = ActiveSheet.UsedRange

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
r = 1: c = 1
For x = 1 To UBound(a)
    For y = 1 To UBound(a, 2)
        If a(x, 1) = vbNullString Then
            r = r + 1
            c = 1
            Exit For
        ElseIf a(x, y) = vbNullString Then
            Exit For
        Else
            b(r, c) = a(x, y)
            If c + 1 > UBound(b, 2) Then
                ReDim Preserve b(1 To UBound(a), 1 To c + 1)
                c = c + 1 '<--- added this line
            Else
                c = c + 1
            End If
        End If
    Next y
Next x

Sheets.Add(after:=Sheets(Sheets.Count)).Range("A1").Resize(UBound(b), UBound(b, 2)) = b

End Sub

[Code Edited : Added one line]
 

mcva

New Member
Joined
Apr 20, 2020
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Thank you works perfectly. I would never have been able to solve this. Now I have an excellent example for studying. Thank you very much!
 

mcva

New Member
Joined
Apr 20, 2020
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Try the updated below code

VBA Code:
Sub PrepareList()

Dim a As Variant, b As Variant, r&, c&
a = ActiveSheet.UsedRange

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
r = 1: c = 1
For x = 1 To UBound(a)
    For y = 1 To UBound(a, 2)
        If a(x, 1) = vbNullString Then
            r = r + 1
            c = 1
            Exit For
        ElseIf a(x, y) = vbNullString Then
            Exit For
        Else
            b(r, c) = a(x, y)
            If c + 1 > UBound(b, 2) Then
                ReDim Preserve b(1 To UBound(a), 1 To c + 1)
                c = c + 1 '<--- added this line
            Else
                c = c + 1
            End If
        End If
    Next y
Next x

Sheets.Add(after:=Sheets(Sheets.Count)).Range("A1").Resize(UBound(b), UBound(b, 2)) = b

End Sub

[Code Edited : Added one line]
Thank you works perfectly. I would never have been able to solve this. Now I have an excellent example for studying. Thank you very much
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
739
Office Version
  1. 365
Platform
  1. Windows
Glad to help & this forum is really a good place to learn from others … I don't have access to your data set but using ReDim Preserve extensively might slow down your code. So if your maximum number of columns is 1200 (8 * 150) then you can change the below line

VBA Code:
ReDim b(1 To UBound(a), 1 To UBound(a, 2)) 'Remove this line

ReDim b(1 To UBound(a), 1 To 1200) 'Replace it with this line
 

Forum statistics

Threads
1,143,677
Messages
5,720,259
Members
422,273
Latest member
linds75

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top