Inserting a number of rows based on the number of columns filled bytext values

  • Thread starter Thread starter zorakramone
  • Start date Start date
Z

zorakramone

Hi

im trying to write a macro that will allow me to automat, inserting
rows based on the number of columns filled by names, then transpose
the names into the rows created.

E.g. from this...

Dave Peter Susan Luke Sam
Bob Brad Pedro
Joanna Pedro Danielle Jim


to this....

Dave Peter
Susan
Luke
Sam
Bob Brad
Pedro
Joanna Pedro
Danielle
Jim

any help would be kindly appreciated
 
With your data starting from cell A1; try the below macro...with a sample..



Sub Macro()
Dim lngRow As Long, lngCol As Long, lngLastRow As Long

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 2
lngRow = 1

Do While Trim(Cells(lngRow, 1)) <> ""
lngCol = 2
Cells(lngLastRow, 1) = Cells(lngRow, 1)
Do While Trim(Cells(lngRow, lngCol)) <> ""
Cells(lngLastRow, 2) = Cells(lngRow, lngCol)
lngCol = lngCol + 1
lngLastRow = lngLastRow + 1
Loop
lngRow = lngRow + 1
Loop

End Sub

If this post helps click Yes
 
Hi

im trying to write a macro that will allow me to automat, inserting
rows based on the number of columns filled by names, then transpose
the names into the rows created.

E.g. from this...

Dave Peter Susan Luke Sam
Bob Brad Pedro
Joanna Pedro Danielle Jim


to this....

Dave Peter
Susan
Luke
Sam
Bob Brad
Pedro
Joanna Pedro
Danielle
Jim

any help would be kindly appreciated
Click to expand...

Try this macro:

Sub zorakramone()
first_row = 1
last_row = Cells(1, 1).End(xlDown).Row
next_new_row = last_row + 1
For r = first_row To last_row
first_column = 2
last_column = Cells(r, 255).End(xlToLeft).Column
Rows(next_new_row).Insert shift:=xlDown
Cells(next_new_row, 1) = Cells(r, 1)
If last_column = 1 Then next_new_row = next_new_row + 1
For c = first_column To last_column
If c > 2 Then Rows(next_new_row).Insert shift:=xlDown
Cells(next_new_row, 2) = Cells(r, c)
next_new_row = next_new_row + 1
Next c
Next r
Rows(first_row & ":" & last_row).Delete shift:=xlUp
End Sub

You can comment out the last statement (Delete) until you have
verified that the result is as expected.

Hope this helps / Lars-Åke
 
I assumed your data start at A1. try this one.

Sub movetest()
Dim Stcell As Range, Encell As Range, Nxcell As Range
Dim n As Long

Application.ScreenUpdating = False
Set Stcell = Cells(1, "A")
Do While (Stcell <> "")
Set Encell = Cells(Stcell.Row, Cells.Columns.Count).End(xlToLeft)
n = Range(Stcell, Encell).Cells.Count
If n > 2 Then
Set Nxcell = Stcell.Offset(1, 0)
Nxcell.Resize(n - 2).EntireRow.Insert
Stcell.Offset(0, 2).Resize(, n - 2).Copy
Stcell.Offset(1, 0).PasteSpecial Transpose:=True
Stcell.Offset(0, 2).Resize(, n - 2).ClearContents
Set Stcell = Nxcell
Else
Set Stcell = Stcell.Offset(1, 0)
End If
Loop

On Error Resume Next
For Each Stcell In Columns("A").SpecialCells(xlCellTypeBlanks)
Stcell.EntireRow.Delete
Next

End Sub

Keiji
 
Back
Top