I have a macro that I'd like to limit the pages it can work on.

Sub columnremove()
Dim myRng As Range
Set myRng = ActiveSheet.Rows(4)
'for rows that have 0's or blanks in column A
'set myRng = activesheet.range("a:a")
With myRng
.Replace What:=0, Replacement:="", LookAt:=xlWhole
On Error Resume Next
.Cells.SpecialCells(xlCellTypeBlanks).EntireColumn .Delete
On Error GoTo 0
End With
End Sub


If i click it, and I am on wrong page it can ruin alot of work, I have
only 3 pages it can work on, Month One, Month Two and Month Three.


Can this macro be made to "check" if its in one of those pages and not
fire, or give an error message if it is not?


Ryk

One way:

Option Explicit
Sub columnremove()
Dim myRng As Range

Select Case LCase(ActiveSheet.Name)
Case Is = LCase("Month One"), LCase("Month Two"), LCase("Month Three")
Set myRng = ActiveSheet.Rows(4)
'for rows that have 0's or blanks in column A
'set myRng = activesheet.range("a:a")
With myRng
.Replace What:=0, Replacement:="", LookAt:=xlWhole
On Error Resume Next
.Cells.SpecialCells(xlCellTypeBlanks).EntireColumn .Delete
On Error GoTo 0
End With
Case Else
MsgBox "Please activate the correct sheet first!"
End Select
End Sub

Ryk wrote:

I have a macro that I'd like to limit the pages it can work on.

Sub columnremove()
Dim myRng As Range
Set myRng = ActiveSheet.Rows(4)
'for rows that have 0's or blanks in column A
'set myRng = activesheet.range("a:a")
With myRng
.Replace What:=0, Replacement:="", LookAt:=xlWhole
On Error Resume Next
.Cells.SpecialCells(xlCellTypeBlanks).EntireColumn .Delete
On Error GoTo 0
End With
End Sub

If i click it, and I am on wrong page it can ruin alot of work, I have
only 3 pages it can work on, Month One, Month Two and Month Three.

Can this macro be made to "check" if its in one of those pages and not
fire, or give an error message if it is not?

Ryk

--

Dave Peterson

Beautiful Dave! Worked like a charm! Hopefully I can sneak in a
second request. After adding that and talking with a co-worker, I came
to realize we only have one other area to address in making the program
safe for multi-user use. I'll be looking into it, but can we make the
saved main program open up and right off the bat and request the user
save it as a different name so the source stays safe? Maybe make it so
they have to save it as a different name or it won't work. I assume I
need find start code, and try and get the code to check the filename,
if its the source name ask to save, if its not then it opens no
problem.

Anyways Dave, this is I think your third major help given to me, you
make me look awful smart, and that is hard to do.

Cheers

Dave (AKA Ryk)

If I don't want users to save over my original workbook, I'll use windows
explorer and mark it readonly.

It stops most of the problems. But I do keep a backup just in case.

But you could use Auto_Open() to do what you want.

Option Explicit
Sub Auto_Open()

Dim Resp As Long
Resp = MsgBox(Prompt:="Do you want to save this as a new name?", _
Buttons:=vbYesNo)

If Resp = vbYes Then
Application.Dialogs(xlDialogSaveAs).Show
End If
End Sub


Ryk wrote:

Beautiful Dave! Worked like a charm! Hopefully I can sneak in a
second request. After adding that and talking with a co-worker, I came
to realize we only have one other area to address in making the program
safe for multi-user use. I'll be looking into it, but can we make the
saved main program open up and right off the bat and request the user
save it as a different name so the source stays safe? Maybe make it so
they have to save it as a different name or it won't work. I assume I
need find start code, and try and get the code to check the filename,
if its the source name ask to save, if its not then it opens no
problem.

Anyways Dave, this is I think your third major help given to me, you
make me look awful smart, and that is hard to do.

Cheers

Dave (AKA Ryk)

--

Dave Peterson

Dave, if i use that, can i set that to only work on original file? We
do alot of work with this, and sometimes its several days of work, I'd
hate to have them need save as a different name each time, only wish to
protect original.


Dave (AKA Ryk)

Opps, as in set it to look for file name as well, like "Hard Copy"? If
its Hard Copy, it asks to save as different name, if not it opens fine.

Option Explicit
Sub Auto_Open()

Dim Resp As Long

if lcase(thisworkbook.name) like "*hard copy*" then
Resp = MsgBox(Prompt:="Do you want to save this as a new name?", _
Buttons:=vbYesNo)

If Resp = vbYes Then
Application.Dialogs(xlDialogSaveAs).Show
End If
end if

End Sub

Ryk wrote:

Opps, as in set it to look for file name as well, like "Hard Copy"? If
its Hard Copy, it asks to save as different name, if not it opens fine.

--

Dave Peterson

Well, I think that all works, gonna try it a few times. As I am new to
posting here and have not be explained the rules, if I have further
questions, should I just keep adding to this one or post a new one?
other question probably easy enough tho, i am using a row
highlighter....

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't
restore
For i = 1 To cnNUMCOLS
.Item(i).Interior.ColorIndex = nColorIndices(i)
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.ColorIndex
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
End Sub

This works just fine, put I have made a copy macro and this interferes
with it a bit, Can i make buttons, that turn a macro on or off? If so
i'd just add the off part to existing... hmmmmmm, i'll add the copy
macro as well, just in case it can be added to shut off the macro while
it copies.

Sub copy1()
'
' copy1 Macro
' Macro recorded 8/22/2006 by ryk'
' Keyboard Shortcut: Ctrl+o
'
Range("A3:AX1006").Select
Selection.Copy
Sheets("Month One").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Month One").Select
Range("A1").Select
Selection.Copy
Sheets("Month One").Select
Range("A1").Select
ActiveSheet.Paste
Range("B6:B1006").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete
Sheets("Suggestions").Select
Range("A5:Z1000").Select
Selection.Copy
Sheets("Suggested Changes").Select
Range("A1").Select
mycell = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & mycell).Select
Selection.PasteSpecial Paste:=xlPasteFormats,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="", Replacement:="$$$$$",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="$$$$$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
mycell = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & mycell).Select


End Sub

If I cannot do on/off for macro I can lose the highlighter, it just
helps because we spend alot of hours a week staring at this program
hehe. More important the copy works, as we remove all the formulas so
we can send out smaller sized files.

Dave, if you answer this, please enlighten me on posting politeness if
I am doing this wrong, as I have really gained alot and don't wish to
**** anyone off heheh.

Many thanks for what you have helped me with though, i hope you get
paid somehow to do this.

Dave

Ryk

Dave does get paid.

His invoice will arrive at your residence within 5 working days.

Or didn't you know about that aspect of these news groups<g


Gord Dibben MS Excel MVP

On 17 Sep 2006 18:55:41 -0700, "Ryk" wrote:

Many thanks for what you have helped me with though, i hope you get
paid somehow to do this.

One way around a problem like this is to not select ranges. But the bad news is
that excel sees a .pastespecial as a selection change. Same thing with the
specialcells stuff.

So you could tell excel to stop monitoring events (like selection changes) right
before you change selection--and tell it to start again when you're done.

Option Explicit
Sub copy1()

Dim DestCell As Range
Dim RngToCopy As Range

With ActiveSheet
Set RngToCopy = .Range("A3:AX1006")
End With

With Worksheets("Month One")
Set DestCell = .Range("a3")
End With

RngToCopy.Copy
With DestCell
Application.EnableEvents = False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.EnableEvents = True
End With

Application.EnableEvents = False
Sheets("Month One").Range("B6:B1006") _
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.EnableEvents = True

With Worksheets("suggestions")
Set RngToCopy = .Range("a5:z1000")
End With

With Worksheets("Suggested Changes")
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

RngToCopy.Copy
With DestCell
Application.EnableEvents = False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.EnableEvents = True
End With

With DestCell.Resize(RngToCopy.Rows.Count, RngToCopy.Columns.Count)
.Replace What:="", Replacement:="$$$$$", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="$$$$$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With

'keep the events enabled here!
With Worksheets("suggested Changes")
Application.Goto .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

End Sub

============

You could actually just turn event monitoring off at the top and and then turn
it back on at the bottom. But as a personal preference, I usually (depending on
the mood I'm in!) like to toggle it off right before it would have fired and
turn it back on right after I'm done hiding from that event.

I think that it makes it a little easier to steal code from old projects, too.
I won't miss what I need when I copy|Paste.

============

And as newsgroup response, I think it's better to start a new thread when the
original question is resolved--but not before. I (as well as most regulars)
hate seeing a new post when there's an active thread elsewhere.

============

And I'll leave any remuneration discussions between you and my financial
manager, Gord!

Ryk wrote:

Well, I think that all works, gonna try it a few times. As I am new to
posting here and have not be explained the rules, if I have further
questions, should I just keep adding to this one or post a new one?
other question probably easy enough tho, i am using a row
highlighter....

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't
restore
For i = 1 To cnNUMCOLS
.Item(i).Interior.ColorIndex = nColorIndices(i)
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.ColorIndex
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
End Sub

This works just fine, put I have made a copy macro and this interferes
with it a bit, Can i make buttons, that turn a macro on or off? If so
i'd just add the off part to existing... hmmmmmm, i'll add the copy
macro as well, just in case it can be added to shut off the macro while
it copies.

Sub copy1()
'
' copy1 Macro
' Macro recorded 8/22/2006 by ryk'
' Keyboard Shortcut: Ctrl+o
'
Range("A3:AX1006").Select
Selection.Copy
Sheets("Month One").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Month One").Select
Range("A1").Select
Selection.Copy
Sheets("Month One").Select
Range("A1").Select
ActiveSheet.Paste
Range("B6:B1006").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete
Sheets("Suggestions").Select
Range("A5:Z1000").Select
Selection.Copy
Sheets("Suggested Changes").Select
Range("A1").Select
mycell = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & mycell).Select
Selection.PasteSpecial Paste:=xlPasteFormats,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="", Replacement:="$$$$$",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="$$$$$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
mycell = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & mycell).Select

End Sub

If I cannot do on/off for macro I can lose the highlighter, it just
helps because we spend alot of hours a week staring at this program
hehe. More important the copy works, as we remove all the formulas so
we can send out smaller sized files.

Dave, if you answer this, please enlighten me on posting politeness if
I am doing this wrong, as I have really gained alot and don't wish to
**** anyone off heheh.

Many thanks for what you have helped me with though, i hope you get
paid somehow to do this.

Dave

--

Dave Peterson

Ok Dave, I plugged that in but its not working. It seems to be
selecting Month one before it shuts off the macro, because the line
highlighter uses yellow, and row 3 copies as yellow now. But I
actually did try too fix it, no worky. it looks to me like the events
thingy is not shutting off. Hmmm hold on a sec.... Can we limit the
rowliner to working in only row 6 to 1006? it seems it is only
affecting row 3 now, makes it copy yellow, and i find out I cannot
change fill colors back, because rowliner code. Maybe rowliner too
much a pain.



Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't
restore
For i = 1 To cnNUMCOLS
.Item(i).Interior.ColorIndex = nColorIndices(i)
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.ColorIndex
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
End Sub

Dave as for the renumeration, I'll email you a beer hehe

First, the events thingy did turn off for me. If you put a break point in the
code, can you step through it and watch what code is executed.

And you can add a check like this:

if intersect(target, me.range("6:1006")) is nothing then
exit sub
end if

At the top of the _selectionchange code.



Ryk wrote:

Ok Dave, I plugged that in but its not working. It seems to be
selecting Month one before it shuts off the macro, because the line
highlighter uses yellow, and row 3 copies as yellow now. But I
actually did try too fix it, no worky. it looks to me like the events
thingy is not shutting off. Hmmm hold on a sec.... Can we limit the
rowliner to working in only row 6 to 1006? it seems it is only
affecting row 3 now, makes it copy yellow, and i find out I cannot
change fill colors back, because rowliner code. Maybe rowliner too
much a pain.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't
restore
For i = 1 To cnNUMCOLS
.Item(i).Interior.ColorIndex = nColorIndices(i)
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.ColorIndex
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
End Sub

Dave as for the renumeration, I'll email you a beer hehe

--

Dave Peterson