Delete rows if copied data >27 rows

[aidan_cov]

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
Sheets("Sheet1").Activate

'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
Selection.Copy

Windows(SourceFile).Activate
Worksheets.Add
Selection.PasteSpecial
Range("A1").Select

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

'Deletes unnecessary columns

Range("C:C,E:E,G:G,H:H,I:I,J:J,K:K,L:L,M:M,N:N").Select
Range("N1").Activate
Selection.Delete Shift:=xlToLeft

'Adds new column header

Range("F8").Select
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
Columns("F:F").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With

'Autofit the new sheet across all columns

Columns("A:F").Select
Columns("A:F").EntireColumn.AutoFit
Range("A1").Select

Sheets("Sheet1").Activate

Range("A1").Select

Sheets("Sheet1").Activate

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

End If

Next Dn
Range("A1").Select
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.

 

[venkat1926]

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
1
2
3
4
hndg 1
5
6
7
hdng 1
7
hdng 1
8


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.

 

[aidan_cov]

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
Range("A28").Activate
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.