Inserting rows and rearranging data using VBA

  • Thread starter Thread starter Lynz
  • Start date Start date
L

Lynz

Hi, I am using excel 2003 and trying to help out a local pony club.
I have a worksheet with lists of data that I need to rearrange to print.
I have no choice in the layout. Data is in columns C,D, G,I
There are different number of entrants in each class, the classes are
numbered.

# Class Pony Rider

1 Hunter Molly John Smith
1 Hunter Pixie Mary Jones
1 Hunter Patch Ellie Martini
2 Jumper Pixie Mary Jones
2 Jumper Patch Ellie Martini
3 Trott Molly John Smith
3 Trott Pixie Mary Jones
3 Trott Sparkle Ann Munroe
3 Trott Patch Ellie Martini

etc.. I need to have it look like this and with a gap between each class


1 Hunter

Molly John Smith
Pixie Mary Jones
Patch Ellie Martini

2 Jumper

Pixie Mary Jones
Patch Ellie Martini

3 Trott

Molly John Smith
Pixie Mary Jones
Sparkle Ann Munroe
Patch Ellie Martini

Would I use bigger row heights to make the gaps? or insert rows? It
would be great to know how to do either . I have tried recording a macro
but as the numbers in the class vary, the ranges vary each time, but the
heaadings etc will be in the same relative place. I am a bit lost, any
help would be much appreciated thank you.
Lyn
 
I wouldn't put extra empty rows in the data. I'd just adjust the rowheight (and
vertical alignment):

Option Explicit
Sub testme()

Dim iWks As Worksheet
Dim oWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Set iWks = Worksheets("Sheet1")
Set oWks = Worksheets.Add

oRow = 0
With iWks
FirstRow = 2 'headers in row 1!
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row

For iRow = FirstRow To LastRow
oRow = oRow + 1
If .Cells(iRow, "c").Value = .Cells(iRow - 1, "c").Value Then
'same group, do details
oWks.Cells(oRow, "b").Value = .Cells(iRow, "G").Value
oWks.Cells(oRow, "c").Value = .Cells(iRow, "I").Value
Else
oWks.Cells(oRow, "A").Value = .Cells(iRow, "c").Value
oWks.Cells(oRow, "B").Value = .Cells(iRow, "d").Value
With oWks.Rows(oRow)
.RowHeight = .RowHeight * 2
.VerticalAlignment = xlCenter
End With
End If
Next iRow
End With
End Sub
 
I wouldn't put extra empty rows in the data. I'd just adjust the
rowheight (and vertical alignment):

Option Explicit
Sub testme()

Dim iWks As Worksheet
Dim oWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Set iWks = Worksheets("Sheet1")
Set oWks = Worksheets.Add

oRow = 0
With iWks
FirstRow = 2 'headers in row 1!
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row

For iRow = FirstRow To LastRow
oRow = oRow + 1
If .Cells(iRow, "c").Value = .Cells(iRow - 1, "c").Value Then
'same group, do details
oWks.Cells(oRow, "b").Value = .Cells(iRow, "G").Value
oWks.Cells(oRow, "c").Value = .Cells(iRow, "I").Value
Else
oWks.Cells(oRow, "A").Value = .Cells(iRow, "c").Value
oWks.Cells(oRow, "B").Value = .Cells(iRow, "d").Value
With oWks.Rows(oRow)
.RowHeight = .RowHeight * 2
.VerticalAlignment = xlCenter
End With
End If
Next iRow
End With
End Sub
Click to expand...
Wow,Thank you! news groups rock. I hope you guys never leave.
Lynz
 
I wouldn't put extra empty rows in the data. I'd just adjust the
rowheight (and vertical alignment):

Option Explicit
Sub testme()

Dim iWks As Worksheet
Dim oWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Set iWks = Worksheets("Sheet1")
Set oWks = Worksheets.Add

oRow = 0
With iWks
FirstRow = 2 'headers in row 1!
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row

For iRow = FirstRow To LastRow
oRow = oRow + 1
If .Cells(iRow, "c").Value = .Cells(iRow - 1, "c").Value Then
'same group, do details
oWks.Cells(oRow, "b").Value = .Cells(iRow, "G").Value
oWks.Cells(oRow, "c").Value = .Cells(iRow, "I").Value
Else
oWks.Cells(oRow, "A").Value = .Cells(iRow, "c").Value
oWks.Cells(oRow, "B").Value = .Cells(iRow, "d").Value
With oWks.Rows(oRow)
.RowHeight = .RowHeight * 2
.VerticalAlignment = xlCenter
End With
End If
Next iRow
End With
End Sub
Click to expand...

Hi Dave I may have to insert the rows to put the class names on as I am
loosing the first row in each class, eg in class 3, trott, I am loosing
"Molly" and "John Smith". Also after 113 classes the entrants have
disapeared, The class numbers and name are there but no horses or
riders. Any idea what might be happening?
Thanks for your valued assistance
lynz
 
Hi Dave I may have to insert the rows to put the class names on as I am
loosing the first row in each class, eg in class 3, trott, I am loosing
"Molly" and "John Smith". Also after 113 classes the entrants have
disapeared, The class numbers and name are there but no horses or
riders. Any idea what might be happening?
Thanks for your valued assistance
lynz
Click to expand...
Just replying to myself here, the reason I had no entrants in the
classes after 113 was because there was only one and it disapeared as
above so that is not a separate problem, sorry for any confusion. I got
lazy with my test data and only put one rider in each of the classes
from 113, sorry.
Lynz
 
No. There is a bug in the original code that would only do the header
information for the first row of a group.

That's not what you want (at least based on your original post).

Try this one:

Option Explicit
Sub testme()

Dim iWks As Worksheet
Dim oWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Set iWks = Worksheets("Sheet1")
Set oWks = Worksheets.Add

oRow = 0
With iWks
FirstRow = 2 'headers in row 1!
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row

For iRow = FirstRow To LastRow

If .Cells(iRow, "c").Value <> .Cells(iRow - 1, "c").Value Then
'new group, add header
oRow = oRow + 1
oWks.Cells(oRow, "A").Value = .Cells(iRow, "c").Value
oWks.Cells(oRow, "B").Value = .Cells(iRow, "d").Value
With oWks.Rows(oRow)
.RowHeight = .RowHeight * 2
.VerticalAlignment = xlCenter
End With
End If

'do this for each input row
oRow = oRow + 1
oWks.Cells(oRow, "b").Value = .Cells(iRow, "G").Value
oWks.Cells(oRow, "c").Value = .Cells(iRow, "I").Value
Next iRow
End With
End Sub
 
Many thanks Dave, this one works as planned. I did try and fix the
previous code but after 23 attempts couldn't get it to work :(
Have a nice day, Lynz
 
Back
Top