Use module, not thisworkbook
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 Befo=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 Befo=ActiveCell
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
End Sub
++++++++++++++++++++++++++++++++++++++++++++++++++ ++++
Jason Lepack wrote:
The problem with speed is not where your code is stored but how your
code is written.
Post your code and myself or someone else will help you speed it up if
at all possible.
Cheers,
Jason Lepack
okrob wrote:
Thanks,
Right now, my code works, but it's runtime is approx 40 sec. So, my
main concern was speed. I have about 1500+/- rows that I have to look
at and find 3 formula parts and when it finds the xlPart, it deletes
the entire row...
It works fine, I just think it takes too long... Although, I may just
be wanting too much. I'll keep digging. Thanks again for the info.
Rob
Bob Phillips wrote:
If you are using workbook events, you clearly have to use ThisWorkbook code
module (at least to initiate the event code). If all of your code is working
on Thisworkbook, just using ThisWorkbook is fine, but if you have more
generic code, that may be used from ThisWorkbook, or a sheet, it is
preferable to put it in a code module, and call it from within the event
code.
Also, if your Thisworkbook or sheet code module is getting very big, it is
wise to split it up, functionally is my preference, and use more standard
code modules.
--
HTH
Bob Phillips
(replace somewhere in email address with gmail if mailing direct)
"okrob" wrote in message
ups.com...
What are the advantages / disadvantages of using thisworkbook over a
module, or a module over thisworkbook for holding code?
Most of my projects seem to work fine by simply using thisworkbook and
the individual sheets (where necessary) and not ever using a separate
module...
Is there a file size consideration? Speed?
Rob
|