Delete rows if copied data >27 rows


New Member
Feb 8, 2007
I have a macro which copies data from a master sheet. It stops each time it see the words "Handset Total" copies all data above it to the previous "Handset Total" and moves on to the next sheet (after some column deletion/formatting and text). The way the data is laid out means that on these copied sheets there could be many headers separating the data. I would like to get rid of this if possible. Is there a small piece of code that could copy the data as it does then delete a specific number of rows containing the duplicate headers? In this case the headers are repeated every 27 rows (if there are more than 27 rows of data for each handset total) and themselves contain 9 rows. So if for instance the data to be copied ran from row 1 to row 50 then all rows would be copied but subsequently rows 28-36 would be deleted as they are duplicates of rows 1-9.

The code I currently have is as follows:

Sub SplitBill()

Dim Rng As Range
Dim Dn As Range

'Display Open Dialog
BillExtract = Application.GetOpenFilename("Excel Files (*.xls*)," & _
"*.xls*", 1, "Select Bill To Extract", "Open", False)

'If user Cancels file selection then exit
If TypeName(BillExtract) = "Boolean" Then
Exit Sub
End If

'Open Result File
Workbooks.Open BillExtract

'Separates the BillExtract name from its full path
SourceFile = Dir(BillExtract)

'Activate the file

'Set the Range as A:A
Set Rng = Range(Range("A:A"), Range("A" & Rows.Count).End(xlUp))

'Find 'Handset Total'
firstRow = 1
For Each Dn In Rng

'Find last filled column
lastCol = ActiveSheet.Range("A1").End(xlToRight).Column

'Return > 0 if match found
If InStr(Dn.Value, "Handset Total") > 0 Then
HSRow = Dn.Row

'Selects range down to Handset Total and across to last column
ActiveSheet.Range("A" & firstRow, ActiveSheet.Cells(HSRow, lastCol)).Select
firstRow = HSRow + 1

'Copies and pastes to new sheet in the Original Bill. Renames new sheet from B6 value


'Removes unwanted character :
NewName = Replace(Range("B6").Value, ":", "")
ActiveSheet.Name = NewName

'Deletes unnecessary columns

Selection.Delete Shift:=xlToLeft

'Adds new column header

ActiveCell.FormulaR1C1 = "JOB NO."

'Formats column header and highlights column

With ActiveCell.Characters(Start:=1, Length:=7).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With

'Autofit the new sheet across all columns





'Sets first Row of next range
Cells(HSRow + 1, 1).Activate

End If

Next Dn
MsgBox ("Macro Finished")

End Sub

Apologies if the code is untidy but I am a relative novice at this and any help would be greatly appreciated.

Many thanks in advance.

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
I suppose the first column of headers will be unique and not repeated any other data in the frist column .

suppose the first column of header is "hdng 1" and the donwloaded data is like this

hdng 1
hndg 1
hdng 1
hdng 1

now autofilter with key field as 1 and criteria as "hdng 1"
then you wll see three such rows. leaving the first row which you need as header row highlight the other two rows and right click and click delete rows.
now again highlighting the first hdng 1 and click data filter autofilter
the autofilter mode is removed and original data with only one heading row is available.

if you need you can have a macro.
Upvote 0
Vankat, thanks for your reply. I managed to come up with a solution on my own eventually. I added a piece of code to my own macro which seems to work. It assumes that there will never be more than about 400 rows (normally the max is about 200) and it deletes the nine rows following the end of the first page and the row locations of each subsequent page whether or not they are copied. It may not be the sleekest but at least it works. It is:

Range( _"28:36,55:63,82:90,109:117,136:144,163:171,190:198,217:225,244:252,271:279,298:
306,325:333,352:360,379:387,406:414" _).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

This then deletes nine rows following the "page" end thereby removing all repeated headers. This also deletes other rows but if they are blank it does not matter.
Like I said I am sure there is a tidier way but I am still learning and at the moment if it works then I am happy. This job used to take about two hours but thanks to this macro now takes about twenty seconds. I love VBA when I can get it to work!
Thanks again.
Upvote 0

Forum statistics

Latest member
Dave Carr QM

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
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 "".
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