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