I'll post it, but I warn you... It's pretty long. The only macro that
is actually called from the worksheet is the DeleteDuplicateRows. I am
posting all relevant subs, and editing out all the "extra" stuff that
doesn't run during it's routines.
++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public nRows As Long
Public C
Public firstAddress
Public Number
Public i As Integer
Sub wbopen()
Dim tdate1 As Date
tdate1 = Date$
Sheet1.Range("E4").Value = tdate1
End Sub
Sub select_every_other_row()
Dim strCol As String, rowStart As Long, rowOffset As Long
Dim rg As Range
Dim Rng As Range
Dim lastRow As Long, i As Long
strCol = "a" 'COLUMN
rowStart = 1 'START SELECTION IN THIS ROW
rowOffset = 2 'SELECT EVERY x ROW
With ActiveSheet
Set rg = .UsedRange.Columns(1) 'determine last row
lastRow = rg.Cells(rg.Cells.Count).Row
Set rg = .Range(strCol & rowStart) 'set initial range
For i = rowStart + rowOffset To lastRow Step rowOffset 'loop
Set rg = Application.Union(rg, .Range(strCol & i))
Next
End With
If rg Is Nothing Then 'no cell
MsgBox "No cell"
Else
rg.Select
End If
With Selection.Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End Sub
Public Sub DeleteDuplicateRows()
ActiveSheet.ResetAllPageBreaks
Dim Col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim Rng As Range
Dim rRow()
On Error GoTo EndMacro
Application.ScreenUpdating = False
nRows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nRows)
Range("C1").Formula = "=A1&B1"
Range("C1").Copy
Range("C2:C" & nRows).PasteSpecial xlPasteFormulas
Range("A1").Select
Application.Calculation = xlCalculationManual
Col = ActiveCell.Column
If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If
N = 0
For r = Rng.Rows.Count To 1 Step -1
V = Rng.Cells(r, 3).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(3), V) > 1
Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r
Range("A1").Select
Call killheader
Range("A1").Select
Call killrows
Range("A1").Select
Call InsertRows
Range("C:C").Delete
Range("A1").Select
Call select_every_other_row
Call truncate
Range("A4:A5").Select
Selection.Cut
Range("A1").Select
Selection.Insert Shift:=xlDown
Range("A1").Interior.ColorIndex = 35
Range("A2").Interior.ColorIndex = xlNone
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
.RightFooter = "&P of &N"
End With
Call pgbrks
Application.ScreenUpdating = True
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub killheader()
Dim Rng As Range, rng1 As Range
Set Rng = Cells(Rows.Count, 1).End(xlUp)
Set Rng = Range(Range("A1"), Rng)
Set rng1 = Rng.Find(What:="GROUP:", _
After:=Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows)
If Not rng1 Is Nothing Then
Range(Range("A1"), _
rng1.Offset(-1, 0)).EntireRow _
.Delete
Else
MsgBox "Try it again please"
End If
End Sub
Sub InsertRows()
On Error Resume Next
Dim rRow()
nRows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nRows)
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A1:A" & nRows)
Set C = .Find(What:="GROUP:", LookIn:=xlFormulas, LookAt:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
Number = Number + 1
rRow(Number) = C.Row
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
For i = Number To 1 Step -1
Range("A" & rRow(i - 1)).EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Sub killrows()
Dim myArr As Variant
Dim Rng As Range
Dim i As Long
'Application.ScreenUpdating = False
myArr = Array("PF KEY", "END OF DATA", "8=FWD")
For i = LBound(myArr) To UBound(myArr)
Do
Set Rng = Range("A:A").Find(What:=myArr(i), _
After:=Range("A" & Rows.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then Rng.EntireRow.Delete
Loop While Not (Rng Is Nothing)
Next i
End Sub
Sub truncate()
Dim cell As Object
On Error Resume Next
For Each cell In Selection.Cells
cell.Value = Right(cell.Value, Len(cell.Value) - 6)
cell.Value = Right(" " & cell.Value, Len(cell.Value) + 6)
Next
End Sub
Sub pgbrks()
On Error Resume Next
Dim rRow()
nRows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nRows)
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A1:A" & nRows)
Set C = .Find(What:="GROUP:", LookIn:=xlFormulas, LookAt:=xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
Number = Number + 1
rRow(Number) = C.Row
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
For i = Number To 1 Step -1
Range("A" & rRow(i - 1)).EntireRow.Select
Selection.End(xlToLeft).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
Next i
Range("A3").Select
ActiveSheet.HPageBreaks(1).Delete
ActiveCell.Offset(3000, 0).Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
End Sub
++++++++++++++++++++++++++++++++++++++++++++++++++++++
