Solved: Insert header rows

[maxflia10]

Aloha,

I've been away from Excel a couple of years until a teacher friend asked for some help.

From the KB knowledge base, I got some code from brettdj to delete rows. Now I need to insert header rows based on a criteria.

I have a sheet with names in column F, which is sorted. I need to insert a header row (taken from A1:G1) when there are name changes. For instance, F3 has teacher A, row F4 has teacher B. Insert the header row, taken from A1:G1 and insert between the names. So the result would be F3 teacher A, F4 the header row and F5 teacher B. The number of rows will vary.

In addition, the list needs to be printed with each teacher's name and info on separate pages. So, in Page Break Preview, the lines for page numbering must be adjusted.

Thank you for reading and Mahalo!

[Bob Phillips]

Untested



Application.Screenupdating = False

With Activesheet

lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row

For i = lastrow - 1 To 3 Step -1

If .Cells(i + 1,"F").Value <> .Cells(i,"F").Value Then

.Rows(i + 1).Insert
.Rows(1).Copy .Cells(i + 1, "A")
End If
Next i

Application.Screenupdating = True

[maxflia10]

Aloha xld,

I get a compile error message,

Invalid Outside Procedure

False is highlighted in blue

[maxflia10]

I've tried to combine the two procedures into one, but of course it errors out. Other than record macros, my skills are nil.


Option Explicit
Sub KillRows()
Dim MyRange As Range, DelRange As Range, C As Range
Dim MatchString As String, SearchColumn As String, ActiveColumn As String
Dim FirstAddress As String, NullCheck As String
Dim AC
'Extract active column as text
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)
SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn)
On Error Resume Next
Set MyRange = Columns(SearchColumn)
On Error GoTo 0
'If an invalid range is entered then exit
If MyRange Is Nothing Then Exit Sub
MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value)
If MatchString = "" Then
NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
"Type Yes to do so, else code will exit", "Caution", "No")
If NullCheck <> "Yes" Then Exit Sub
End If
Application.ScreenUpdating = False
'to match the WHOLE text string
Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole)
'to match a PARTIAL text string use this line
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)
'to match the case and of a WHOLE text string
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)
If Not C Is Nothing Then
Set DelRange = C
FirstAddress = C.Address
Do
Set C = MyRange.FindNext(C)
Set DelRange = Union(DelRange, C)
Loop While FirstAddress <> C.Address
End If
'If there are valid matches then delete the rows
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
End Sub

With ActiveSheet
lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = lastrow - 1 To 3 Step -1
If .Cells(i + 1, "F").Value <> .Cells(i, "F").Value Then
.Rows(i + 1).Insert
.Rows(1).Copy .Cells(i + 1, "A")
End If
Next i
Application.ScreenUpdating = True

[Bob Phillips]

I can only change it by sight as I don't have your data to test it on

Sub KillRows()
Dim MyRange As Range, DelRange As Range, C As Range
Dim MatchString As String, SearchColumn As String, ActiveColumn As String
Dim FirstAddress As String, NullCheck As String
Dim AC
Dim lastrow As Long

'Extract active column as text
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)

SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn)

On Error Resume Next
Set MyRange = Columns(SearchColumn)
On Error GoTo 0

'If an invalid range is entered then exit
If MyRange Is Nothing Then Exit Sub

MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value)
If MatchString = "" Then
NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
"Type Yes to do so, else code will exit", "Caution", "No")
If NullCheck <> "Yes" Then Exit Sub
End If

Application.ScreenUpdating = False

'to match the WHOLE text string
Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole)
'to match a PARTIAL text string use this line
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)
'to match the case and of a WHOLE text string
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)

If Not C Is Nothing Then
Set DelRange = C
FirstAddress = C.Address
Do
Set C = MyRange.FindNext(C)
Set DelRange = Union(DelRange, C)
Loop While FirstAddress <> C.Address
End If

'If there are valid matches then delete the rows
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete

With ActiveSheet

lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row

For i = lastrow - 1 To 3 Step -1

If .Cells(i + 1, "F").Value <> .Cells(i, "F").Value Then

.Rows(i + 1).Insert
.Rows(1).Copy .Cells(i + 1, "A")
End If
Next i
End With

Application.ScreenUpdating = True
End Sub

[maxflia10]

Thanks for your help xld, appreciate your time. The second part of the code, to insert rows does not fire. I've attached a sample file this time. I forgot you can do this here. I've also recorded a sort macro, which I forgot the first time. I tried to insert the macro between the two procedures, but.......


Sub Macro1()
'Macro1 Macro
' Macro recorded 03/07/2013 by '
'
Range("A1:J1").Select
Range("A1:O287").Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:=Range _
("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("A1").Select
End Sub

[maxflia10]

Oooops, the file didn't load.

[maxflia10]

Would it be easier/smarter if I had three separate codes to run, instead of trying to fit all of it in one?

Thanks

[Bob Phillips]

Option Explicit

Sub KillRows()

Application.ScreenUpdating = False

Call SortData(activesheet)

Call DeleteExistingHeaders(activesheet)

Call InsertHeaders(activesheet)

Application.ScreenUpdating = True
End Sub

Private Sub SortData(ByRef sh As Worksheet)
Dim lastrow As Long
Dim lastcol As Long

With sh

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A1").Resize(lastrow, lastcol).Sort Key1:=.Range("E2"), Order1:=xlAscending, _
Key2:=.Range("A2"), Order2:=xlAscending, _
Header:=xlYes
End With
End Sub

Private Sub DeleteExistingHeaders(ByRef sh As Worksheet)
Dim MyRange As Range, DelRange As Range, C As Range
Dim MatchString As String, SearchColumn As String, ActiveColumn As String
Dim FirstAddress As String, NullCheck As String
Dim AC

With sh

'Extract active column as text
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)

SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn)

On Error Resume Next
Set MyRange = .Range(.Cells(2, SearchColumn), .Cells(2, SearchColumn).End(xlDown))
On Error GoTo 0

'If an invalid range is entered then exit
If MyRange Is Nothing Then Exit Sub

MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value)
If MatchString = "" Then
NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
"Type Yes to do so, else code will exit", "Caution", "No")
If NullCheck <> "Yes" Then Exit Sub
End If

Application.ScreenUpdating = False

'to match the WHOLE text string
Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole)
'to match a PARTIAL text string use this line
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)
'to match the case and of a WHOLE text string
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)

If Not C Is Nothing Then
Set DelRange = C
FirstAddress = C.Address
Do
Set C = MyRange.FindNext(C)
Set DelRange = Union(DelRange, C)
Loop While FirstAddress <> C.Address
End If

'If there are valid matches then delete the rows
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
End With
End Sub

Private Sub InsertHeaders(ByRef sh As Worksheet)
Dim lastrow As Long
Dim i As Long

With sh

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = lastrow - 1 To 3 Step -1

If .Cells(i + 1, "E").Value <> .Cells(i, "E").Value Then

.Rows(i + 1).Insert
.Rows(1).Copy .Cells(i + 1, "A")
End If
Next i
End With
End Sub

[maxflia10]

WOW xld, work perfect!

I know I'm pushing my luck, but is there anyway you can set the print area or page break so that each header row and info is printed on separate pages?

Presently, I do a manual moving of the lines in page break preview.

Thanks, you've saved me/us a ton of time trying to format the sheets.

[maxflia10]

Gently bumping! :blush

[SamT]

Try this one. It treats Sheet("Raw") as a database and changes nothing on it.
The initiating macro "PrepareSheetForPrinting" calls two private procedures
Public Sub PrepareSheetForPrinting()
Dim WkSht As Worksheet
Set WkSht = ThisWorkbook.Sheets("Raw")

SortTeacherThenStudent WkSht
DoEvents
SetupPage WkSht
End Sub
The Sort procedure is from XLD and the SetUpPage procedure prepares the Sheet's print properties. TRy unsorting the sheet first.

See if running the macro from Excel's Tools Menu and then printing the sheet with Excel's file menu does what you want. If we get that far, we can automate the printing, if needed

The other macro available from the Tool menu is "CleanUpAfterPrinting." It removes all the Sheet's Print properties.

It shuld probably be named "CleanUpBeforeSettingUp" and moved to the front of "SetUpPage." oops.

Everything compiles, but I don't have a printer, so... let me know.

There is a procedure in modCleanUp I used to convert your worksheet "Raw" into a clean DB.

[maxflia10]

Sorry for the delay in responding. I must be doing something wrong here. I run xld's code, then yours but........

The code errors at

.PrintArea = WkSht.Range("A1").Resize(LastRow, LastCol)

[SamT]

My Bad, PrintArea is a String
.PrintArea = WkSht.Range("A1").Resize(LastRow, LastCol).Address Actually, I had to change a couple more lines. Here is the newest version

[maxflia10]

MAHALO! (Thank you) to xld & SamT.

Appreciate your time. This will save my friend a lot of time.