Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Ws Selection Change Event Code, Copy a Cell problem
Hi All, I'm just getting my ankles in the water ws selection change event code. The sub below is doing what I want, selection. The users are NOT Excel wizards, hence maybe going over- board in trying to control the cursor. PROBLEM: Testing the sheet, when I right click a 'good' cell after selecting it to copy it to another cell, I lose the wavy lines when this code ends, and cannot use paste to complete the copy. I don't want to force the user to type all of the data. This sheet is a 'main' adjusting sheet in my app. All the macros sit in an addin. I don't know what I'm leaving out. I don't know how to bring forward into the change event code a 'right-clicked range' to be copied. There is a Ws change event macro, not shown here. If I must, I could move this logic to it. Ugh. Thanks, Neal Z. Sub SVC_SelChg(ByVal CellAdr As String) ' CellAdr is target.address ' Edit all SubViewChg Ws selections. Keep protection on. Const Title = "Subscriber Data View/Change" Dim RngType As String Dim Status As String Dim Row As Long, Ix As Integer Dim BlankRowAy() As Long Dim ChgRow As Long, ChgCol As Integer Dim HIrow As Long, HIcol As Integer Dim ActRow As Long, ActCol As Integer Dim PaBegRow As Long '1st row holding Pa account Dim PaEndRow As Long 'last poss row for pa sel/chg Dim LastExistACNrow As Long Dim ACNcanBeAddRow As Long 'row of 'accounts can be added' literal Dim LastAbrRow As Long 'last row with pa abr, above final 2 blank rows Dim LastAdrRow As Long 'last row top half, N&Adr sub data Dim COfs As Integer 'Ws column offset to SVrAy columns. Dim Qty As Integer Dim ExistACNrng As Range 'data can't be changed here Dim DrawRng As Range 'mod subscr & temp stops cols, not these. Dim ISect As Range 'intersect, test bad selections from above Dim LastAddRng As Range 'final two rows PaAbr thru subscr. 'mainline start EventsOFF ' disables events COfs = gSVCwsColOfs ' Col offset lines up Ws with array receiving data later ' BREAKDOWN CELLADR (target.address) INTO ROWS COLS Call RowsCols_vCellAdr(CellAdr, RngType, ChgRow, ChgCol, _ HIrow, HIcol, ActRow, ActCol) ' ID KEY Ws LOGIC ROWS PaBegRow = gSVCpaBegRow 'row after col hdr's g = public constant LastExistACNrow = Range("c1").Value PaEndRow = Range(SIdCpaEndRow).Value ' usually e1 LastAdrRow = PaBegRow - 2 'row above col hdr's LastAbrRow = PaEndRow - 2 ACNcanBeAddRow = Range("d1").Value - 1 Set ExistACNrng = Range(Cells(PaBegRow, SVrPaAbrCol + COfs), _ Cells(Range("c1").Value, SVrACNcol + COfs)) Set DrawRng = Range(Cells(PaBegRow, SVrDrawCol + COfs), _ Cells(PaEndRow, SVrDrawCol + COfs)) Set LastAddRng = Range(Cells(PaEndRow - 1, SVrPaAbrCol + COfs), _ Cells(PaEndRow, SVrSubscrCol + COfs)) If InStr(CellAdr, Comma) 0 Then ' non contiguous ranges, no no MsgBox "Invalid, using Ctrl Key to select non-contiguous cells, " _ & Cr2 & "is Not Allowed on this sheet.", vbCritical, Title GoTo Quit End If ' last row limitation If ChgRow PaEndRow Then MsgBox "Row " & PaEndRow & " is last valid row to select.", _ vbExclamation, Title Cells(PaEndRow, SVrPaAbrCol + COfs).Select GoTo Quit End If ' right most col limitation If ChgCol SVrSubNaCol + COfs Then MsgBox "Column " & ColLtrs_FmNumF(SVrSubNaCol + COfs) _ & " is rightmost valid column to select.", _ vbExclamation, Title Cells(ChgRow, SVrSubNaCol + COfs).Select GoTo Quit End If ' build array for blank 'visual spacer row' NON-selection ReDim BlankRowAy(20) For Row = PaBegRow + 1 To LastAbrRow - 1 If Cells(Row, SVrPaAbrCol + COfs) = "" Or Row = ACNcanBeAddRow Then Qty = Qty + 1 If Qty UBound(BlankRowAy) Then ReDim Preserve BlankRowAy(Qty) BlankRowAy(Qty) = Row End If Next Row For Ix = 1 To Qty If ChgRow = BlankRowAy(Ix) Then MsgBox "Invalid Row for Selection.", vbExclamation, Title If ChgRow < ACNcanBeAddRow Then ChgRow = ChgRow - 1 Else _ If ChgRow = ACNcanBeAddRow Then ChgRow = ChgRow + 1 Else _ ChgRow = ChgRow - 1 Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If Next Ix ' can't change draw directly Set ISect = Application.Intersect(DrawRng, Selection) If Not ISect Is Nothing Then DrawRng.Select MsgBox "Please change subscription or temp stops, NOT the draw.", _ vbExclamation, Title Range(Cells(ChgRow, SVrSubscrCol + COfs), _ Cells(ChgRow, SVrOthTScol + COfs)).Select GoTo Quit End If ' can't change key existing account data Set ISect = Application.Intersect(ExistACNrng, Selection) If Not ISect Is Nothing Then ExistACNrng.Select MsgBox "Data here can't be changed. Change subscription or temp stops.", _ vbExclamation, Title LastAddRng.Select MsgBox "OR ... ADD accounts in above cells," & Cr2 & "OR to add a " _ & "2nd or 3rd account, using these cells.", vbExclamation, Title Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If If ChgCol = iColA Then 'column A is no-man's land. Application.MoveAfterReturnDirection = xlToRight If PaBegRow <= ChgRow And ChgRow <= LastExistACNrow Then Cells(ChgRow, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ACNcanBeAddRow < ChgRow And ChgRow <= LastAbrRow Then Cells(ChgRow, SVrDlvCol + COfs).Select ElseIf LastAbrRow < ChgRow And ChgRow <= PaEndRow Then Cells(ChgRow, SVrPaAbrCol + COfs).Select End If ElseIf ChgCol < (SVrSubNaCol + COfs) Then Application.MoveAfterReturnDirection = xlToRight ElseIf ChgCol = (SVrSubNaCol + COfs) Then 'rightmost allowable Application.MoveAfterReturnDirection = xlToLeft End If If ChgRow < HIrow And ChgCol < (SVrSubNaCol + COfs) Then MsgBox "Please select in only 1 row.", vbExclamation, Title Cells(ChgRow, ChgCol).Select End If Quit: Call SVC_Protect ' protects this sheet, enables events 'mainline end End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Ws Selection Change Event Code, Copy a Cell problem
Without looking at the code -- I stopped reading after the description that
you're losing the "marching ants" around the copied range. One of the "features" of macros, including events, is that they can destroy the cutcopymode. The only way I know to avoid this problem is to avoid macros that do clear the cutcopymode. (Some minor macros don't do any harm.) Maybe you could add code to your macro that asks the users for the range to be copied and the range where it should be pasted. Neal Zimm wrote: Hi All, I'm just getting my ankles in the water ws selection change event code. The sub below is doing what I want, selection. The users are NOT Excel wizards, hence maybe going over- board in trying to control the cursor. PROBLEM: Testing the sheet, when I right click a 'good' cell after selecting it to copy it to another cell, I lose the wavy lines when this code ends, and cannot use paste to complete the copy. I don't want to force the user to type all of the data. This sheet is a 'main' adjusting sheet in my app. All the macros sit in an addin. I don't know what I'm leaving out. I don't know how to bring forward into the change event code a 'right-clicked range' to be copied. There is a Ws change event macro, not shown here. If I must, I could move this logic to it. Ugh. Thanks, Neal Z. Sub SVC_SelChg(ByVal CellAdr As String) ' CellAdr is target.address ' Edit all SubViewChg Ws selections. Keep protection on. Const Title = "Subscriber Data View/Change" Dim RngType As String Dim Status As String Dim Row As Long, Ix As Integer Dim BlankRowAy() As Long Dim ChgRow As Long, ChgCol As Integer Dim HIrow As Long, HIcol As Integer Dim ActRow As Long, ActCol As Integer Dim PaBegRow As Long '1st row holding Pa account Dim PaEndRow As Long 'last poss row for pa sel/chg Dim LastExistACNrow As Long Dim ACNcanBeAddRow As Long 'row of 'accounts can be added' literal Dim LastAbrRow As Long 'last row with pa abr, above final 2 blank rows Dim LastAdrRow As Long 'last row top half, N&Adr sub data Dim COfs As Integer 'Ws column offset to SVrAy columns. Dim Qty As Integer Dim ExistACNrng As Range 'data can't be changed here Dim DrawRng As Range 'mod subscr & temp stops cols, not these. Dim ISect As Range 'intersect, test bad selections from above Dim LastAddRng As Range 'final two rows PaAbr thru subscr. 'mainline start EventsOFF ' disables events COfs = gSVCwsColOfs ' Col offset lines up Ws with array receiving data later ' BREAKDOWN CELLADR (target.address) INTO ROWS COLS Call RowsCols_vCellAdr(CellAdr, RngType, ChgRow, ChgCol, _ HIrow, HIcol, ActRow, ActCol) ' ID KEY Ws LOGIC ROWS PaBegRow = gSVCpaBegRow 'row after col hdr's g = public constant LastExistACNrow = Range("c1").Value PaEndRow = Range(SIdCpaEndRow).Value ' usually e1 LastAdrRow = PaBegRow - 2 'row above col hdr's LastAbrRow = PaEndRow - 2 ACNcanBeAddRow = Range("d1").Value - 1 Set ExistACNrng = Range(Cells(PaBegRow, SVrPaAbrCol + COfs), _ Cells(Range("c1").Value, SVrACNcol + COfs)) Set DrawRng = Range(Cells(PaBegRow, SVrDrawCol + COfs), _ Cells(PaEndRow, SVrDrawCol + COfs)) Set LastAddRng = Range(Cells(PaEndRow - 1, SVrPaAbrCol + COfs), _ Cells(PaEndRow, SVrSubscrCol + COfs)) If InStr(CellAdr, Comma) 0 Then ' non contiguous ranges, no no MsgBox "Invalid, using Ctrl Key to select non-contiguous cells, " _ & Cr2 & "is Not Allowed on this sheet.", vbCritical, Title GoTo Quit End If ' last row limitation If ChgRow PaEndRow Then MsgBox "Row " & PaEndRow & " is last valid row to select.", _ vbExclamation, Title Cells(PaEndRow, SVrPaAbrCol + COfs).Select GoTo Quit End If ' right most col limitation If ChgCol SVrSubNaCol + COfs Then MsgBox "Column " & ColLtrs_FmNumF(SVrSubNaCol + COfs) _ & " is rightmost valid column to select.", _ vbExclamation, Title Cells(ChgRow, SVrSubNaCol + COfs).Select GoTo Quit End If ' build array for blank 'visual spacer row' NON-selection ReDim BlankRowAy(20) For Row = PaBegRow + 1 To LastAbrRow - 1 If Cells(Row, SVrPaAbrCol + COfs) = "" Or Row = ACNcanBeAddRow Then Qty = Qty + 1 If Qty UBound(BlankRowAy) Then ReDim Preserve BlankRowAy(Qty) BlankRowAy(Qty) = Row End If Next Row For Ix = 1 To Qty If ChgRow = BlankRowAy(Ix) Then MsgBox "Invalid Row for Selection.", vbExclamation, Title If ChgRow < ACNcanBeAddRow Then ChgRow = ChgRow - 1 Else _ If ChgRow = ACNcanBeAddRow Then ChgRow = ChgRow + 1 Else _ ChgRow = ChgRow - 1 Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If Next Ix ' can't change draw directly Set ISect = Application.Intersect(DrawRng, Selection) If Not ISect Is Nothing Then DrawRng.Select MsgBox "Please change subscription or temp stops, NOT the draw.", _ vbExclamation, Title Range(Cells(ChgRow, SVrSubscrCol + COfs), _ Cells(ChgRow, SVrOthTScol + COfs)).Select GoTo Quit End If ' can't change key existing account data Set ISect = Application.Intersect(ExistACNrng, Selection) If Not ISect Is Nothing Then ExistACNrng.Select MsgBox "Data here can't be changed. Change subscription or temp stops.", _ vbExclamation, Title LastAddRng.Select MsgBox "OR ... ADD accounts in above cells," & Cr2 & "OR to add a " _ & "2nd or 3rd account, using these cells.", vbExclamation, Title Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If If ChgCol = iColA Then 'column A is no-man's land. Application.MoveAfterReturnDirection = xlToRight If PaBegRow <= ChgRow And ChgRow <= LastExistACNrow Then Cells(ChgRow, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ACNcanBeAddRow < ChgRow And ChgRow <= LastAbrRow Then Cells(ChgRow, SVrDlvCol + COfs).Select ElseIf LastAbrRow < ChgRow And ChgRow <= PaEndRow Then Cells(ChgRow, SVrPaAbrCol + COfs).Select End If ElseIf ChgCol < (SVrSubNaCol + COfs) Then Application.MoveAfterReturnDirection = xlToRight ElseIf ChgCol = (SVrSubNaCol + COfs) Then 'rightmost allowable Application.MoveAfterReturnDirection = xlToLeft End If If ChgRow < HIrow And ChgCol < (SVrSubNaCol + COfs) Then MsgBox "Please select in only 1 row.", vbExclamation, Title Cells(ChgRow, ChgCol).Select End If Quit: Call SVC_Protect ' protects this sheet, enables events 'mainline end End Sub -- Dave Peterson |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Ws Selection Change Event Code, Copy a Cell problem
Hi again Dave -
Actually, kinda glad to hear your answer, it's what I had guessed after stepping thru the code a couple of times before I submitted this posting to the community; as I could 'see' nothing wrong going on. Can I assume that moving the selection event logic to the change event macro would still give the same result ? If it does, there's no real harm in having the user key the data. The ws in question, is the result of a query the user makes, and user is entering data to change an account. Mostly single digits, it would be overkill to ask again what cells does user want to copy. Was jes tryin' to be thorough in my testing. Thanks again, Neal -- Neal Z "Dave Peterson" wrote: Without looking at the code -- I stopped reading after the description that you're losing the "marching ants" around the copied range. One of the "features" of macros, including events, is that they can destroy the cutcopymode. The only way I know to avoid this problem is to avoid macros that do clear the cutcopymode. (Some minor macros don't do any harm.) Maybe you could add code to your macro that asks the users for the range to be copied and the range where it should be pasted. Neal Zimm wrote: Hi All, I'm just getting my ankles in the water ws selection change event code. The sub below is doing what I want, selection. The users are NOT Excel wizards, hence maybe going over- board in trying to control the cursor. PROBLEM: Testing the sheet, when I right click a 'good' cell after selecting it to copy it to another cell, I lose the wavy lines when this code ends, and cannot use paste to complete the copy. I don't want to force the user to type all of the data. This sheet is a 'main' adjusting sheet in my app. All the macros sit in an addin. I don't know what I'm leaving out. I don't know how to bring forward into the change event code a 'right-clicked range' to be copied. There is a Ws change event macro, not shown here. If I must, I could move this logic to it. Ugh. Thanks, Neal Z. Sub SVC_SelChg(ByVal CellAdr As String) ' CellAdr is target.address ' Edit all SubViewChg Ws selections. Keep protection on. Const Title = "Subscriber Data View/Change" Dim RngType As String Dim Status As String Dim Row As Long, Ix As Integer Dim BlankRowAy() As Long Dim ChgRow As Long, ChgCol As Integer Dim HIrow As Long, HIcol As Integer Dim ActRow As Long, ActCol As Integer Dim PaBegRow As Long '1st row holding Pa account Dim PaEndRow As Long 'last poss row for pa sel/chg Dim LastExistACNrow As Long Dim ACNcanBeAddRow As Long 'row of 'accounts can be added' literal Dim LastAbrRow As Long 'last row with pa abr, above final 2 blank rows Dim LastAdrRow As Long 'last row top half, N&Adr sub data Dim COfs As Integer 'Ws column offset to SVrAy columns. Dim Qty As Integer Dim ExistACNrng As Range 'data can't be changed here Dim DrawRng As Range 'mod subscr & temp stops cols, not these. Dim ISect As Range 'intersect, test bad selections from above Dim LastAddRng As Range 'final two rows PaAbr thru subscr. 'mainline start EventsOFF ' disables events COfs = gSVCwsColOfs ' Col offset lines up Ws with array receiving data later ' BREAKDOWN CELLADR (target.address) INTO ROWS COLS Call RowsCols_vCellAdr(CellAdr, RngType, ChgRow, ChgCol, _ HIrow, HIcol, ActRow, ActCol) ' ID KEY Ws LOGIC ROWS PaBegRow = gSVCpaBegRow 'row after col hdr's g = public constant LastExistACNrow = Range("c1").Value PaEndRow = Range(SIdCpaEndRow).Value ' usually e1 LastAdrRow = PaBegRow - 2 'row above col hdr's LastAbrRow = PaEndRow - 2 ACNcanBeAddRow = Range("d1").Value - 1 Set ExistACNrng = Range(Cells(PaBegRow, SVrPaAbrCol + COfs), _ Cells(Range("c1").Value, SVrACNcol + COfs)) Set DrawRng = Range(Cells(PaBegRow, SVrDrawCol + COfs), _ Cells(PaEndRow, SVrDrawCol + COfs)) Set LastAddRng = Range(Cells(PaEndRow - 1, SVrPaAbrCol + COfs), _ Cells(PaEndRow, SVrSubscrCol + COfs)) If InStr(CellAdr, Comma) 0 Then ' non contiguous ranges, no no MsgBox "Invalid, using Ctrl Key to select non-contiguous cells, " _ & Cr2 & "is Not Allowed on this sheet.", vbCritical, Title GoTo Quit End If ' last row limitation If ChgRow PaEndRow Then MsgBox "Row " & PaEndRow & " is last valid row to select.", _ vbExclamation, Title Cells(PaEndRow, SVrPaAbrCol + COfs).Select GoTo Quit End If ' right most col limitation If ChgCol SVrSubNaCol + COfs Then MsgBox "Column " & ColLtrs_FmNumF(SVrSubNaCol + COfs) _ & " is rightmost valid column to select.", _ vbExclamation, Title Cells(ChgRow, SVrSubNaCol + COfs).Select GoTo Quit End If ' build array for blank 'visual spacer row' NON-selection ReDim BlankRowAy(20) For Row = PaBegRow + 1 To LastAbrRow - 1 If Cells(Row, SVrPaAbrCol + COfs) = "" Or Row = ACNcanBeAddRow Then Qty = Qty + 1 If Qty UBound(BlankRowAy) Then ReDim Preserve BlankRowAy(Qty) BlankRowAy(Qty) = Row End If Next Row For Ix = 1 To Qty If ChgRow = BlankRowAy(Ix) Then MsgBox "Invalid Row for Selection.", vbExclamation, Title If ChgRow < ACNcanBeAddRow Then ChgRow = ChgRow - 1 Else _ If ChgRow = ACNcanBeAddRow Then ChgRow = ChgRow + 1 Else _ ChgRow = ChgRow - 1 Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If Next Ix ' can't change draw directly Set ISect = Application.Intersect(DrawRng, Selection) If Not ISect Is Nothing Then DrawRng.Select MsgBox "Please change subscription or temp stops, NOT the draw.", _ vbExclamation, Title Range(Cells(ChgRow, SVrSubscrCol + COfs), _ Cells(ChgRow, SVrOthTScol + COfs)).Select GoTo Quit End If ' can't change key existing account data Set ISect = Application.Intersect(ExistACNrng, Selection) If Not ISect Is Nothing Then ExistACNrng.Select MsgBox "Data here can't be changed. Change subscription or temp stops.", _ vbExclamation, Title LastAddRng.Select MsgBox "OR ... ADD accounts in above cells," & Cr2 & "OR to add a " _ & "2nd or 3rd account, using these cells.", vbExclamation, Title Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If If ChgCol = iColA Then 'column A is no-man's land. Application.MoveAfterReturnDirection = xlToRight If PaBegRow <= ChgRow And ChgRow <= LastExistACNrow Then Cells(ChgRow, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ACNcanBeAddRow < ChgRow And ChgRow <= LastAbrRow Then Cells(ChgRow, SVrDlvCol + COfs).Select ElseIf LastAbrRow < ChgRow And ChgRow <= PaEndRow Then Cells(ChgRow, SVrPaAbrCol + COfs).Select End If ElseIf ChgCol < (SVrSubNaCol + COfs) Then Application.MoveAfterReturnDirection = xlToRight ElseIf ChgCol = (SVrSubNaCol + COfs) Then 'rightmost allowable Application.MoveAfterReturnDirection = xlToLeft End If If ChgRow < HIrow And ChgCol < (SVrSubNaCol + COfs) Then MsgBox "Please select in only 1 row.", vbExclamation, Title Cells(ChgRow, ChgCol).Select End If Quit: Call SVC_Protect ' protects this sheet, enables events 'mainline end End Sub -- Dave Peterson |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Ws Selection Change Event Code, Copy a Cell problem
I'm guessing that it won't make a difference (that you'll still have the
problem). But the only way to tell for sure is to test it. ==== I still haven't looked at the code, but maybe you could tell the user to select the range first, then just ask where to paste? dim RngToCopy as range dim destcell as range set rngtocopy = selection .... Then determine the destination cell set destcell = nothing on error resume next set destcell = application.inputbox(prompt:="select a cell", type:=8).cells(1) on error goto 0 if destcell is nothing then 'user hit cancel exit sub '?? end if then you could do the copy (and all your checking)... rngtocopy.copy _ destination:=destcell (just an idea--it may not be close to what you want to do.) Neal Zimm wrote: Hi again Dave - Actually, kinda glad to hear your answer, it's what I had guessed after stepping thru the code a couple of times before I submitted this posting to the community; as I could 'see' nothing wrong going on. Can I assume that moving the selection event logic to the change event macro would still give the same result ? If it does, there's no real harm in having the user key the data. The ws in question, is the result of a query the user makes, and user is entering data to change an account. Mostly single digits, it would be overkill to ask again what cells does user want to copy. Was jes tryin' to be thorough in my testing. Thanks again, Neal -- Neal Z "Dave Peterson" wrote: Without looking at the code -- I stopped reading after the description that you're losing the "marching ants" around the copied range. One of the "features" of macros, including events, is that they can destroy the cutcopymode. The only way I know to avoid this problem is to avoid macros that do clear the cutcopymode. (Some minor macros don't do any harm.) Maybe you could add code to your macro that asks the users for the range to be copied and the range where it should be pasted. Neal Zimm wrote: Hi All, I'm just getting my ankles in the water ws selection change event code. The sub below is doing what I want, selection. The users are NOT Excel wizards, hence maybe going over- board in trying to control the cursor. PROBLEM: Testing the sheet, when I right click a 'good' cell after selecting it to copy it to another cell, I lose the wavy lines when this code ends, and cannot use paste to complete the copy. I don't want to force the user to type all of the data. This sheet is a 'main' adjusting sheet in my app. All the macros sit in an addin. I don't know what I'm leaving out. I don't know how to bring forward into the change event code a 'right-clicked range' to be copied. There is a Ws change event macro, not shown here. If I must, I could move this logic to it. Ugh. Thanks, Neal Z. Sub SVC_SelChg(ByVal CellAdr As String) ' CellAdr is target.address ' Edit all SubViewChg Ws selections. Keep protection on. Const Title = "Subscriber Data View/Change" Dim RngType As String Dim Status As String Dim Row As Long, Ix As Integer Dim BlankRowAy() As Long Dim ChgRow As Long, ChgCol As Integer Dim HIrow As Long, HIcol As Integer Dim ActRow As Long, ActCol As Integer Dim PaBegRow As Long '1st row holding Pa account Dim PaEndRow As Long 'last poss row for pa sel/chg Dim LastExistACNrow As Long Dim ACNcanBeAddRow As Long 'row of 'accounts can be added' literal Dim LastAbrRow As Long 'last row with pa abr, above final 2 blank rows Dim LastAdrRow As Long 'last row top half, N&Adr sub data Dim COfs As Integer 'Ws column offset to SVrAy columns. Dim Qty As Integer Dim ExistACNrng As Range 'data can't be changed here Dim DrawRng As Range 'mod subscr & temp stops cols, not these. Dim ISect As Range 'intersect, test bad selections from above Dim LastAddRng As Range 'final two rows PaAbr thru subscr. 'mainline start EventsOFF ' disables events COfs = gSVCwsColOfs ' Col offset lines up Ws with array receiving data later ' BREAKDOWN CELLADR (target.address) INTO ROWS COLS Call RowsCols_vCellAdr(CellAdr, RngType, ChgRow, ChgCol, _ HIrow, HIcol, ActRow, ActCol) ' ID KEY Ws LOGIC ROWS PaBegRow = gSVCpaBegRow 'row after col hdr's g = public constant LastExistACNrow = Range("c1").Value PaEndRow = Range(SIdCpaEndRow).Value ' usually e1 LastAdrRow = PaBegRow - 2 'row above col hdr's LastAbrRow = PaEndRow - 2 ACNcanBeAddRow = Range("d1").Value - 1 Set ExistACNrng = Range(Cells(PaBegRow, SVrPaAbrCol + COfs), _ Cells(Range("c1").Value, SVrACNcol + COfs)) Set DrawRng = Range(Cells(PaBegRow, SVrDrawCol + COfs), _ Cells(PaEndRow, SVrDrawCol + COfs)) Set LastAddRng = Range(Cells(PaEndRow - 1, SVrPaAbrCol + COfs), _ Cells(PaEndRow, SVrSubscrCol + COfs)) If InStr(CellAdr, Comma) 0 Then ' non contiguous ranges, no no MsgBox "Invalid, using Ctrl Key to select non-contiguous cells, " _ & Cr2 & "is Not Allowed on this sheet.", vbCritical, Title GoTo Quit End If ' last row limitation If ChgRow PaEndRow Then MsgBox "Row " & PaEndRow & " is last valid row to select.", _ vbExclamation, Title Cells(PaEndRow, SVrPaAbrCol + COfs).Select GoTo Quit End If ' right most col limitation If ChgCol SVrSubNaCol + COfs Then MsgBox "Column " & ColLtrs_FmNumF(SVrSubNaCol + COfs) _ & " is rightmost valid column to select.", _ vbExclamation, Title Cells(ChgRow, SVrSubNaCol + COfs).Select GoTo Quit End If ' build array for blank 'visual spacer row' NON-selection ReDim BlankRowAy(20) For Row = PaBegRow + 1 To LastAbrRow - 1 If Cells(Row, SVrPaAbrCol + COfs) = "" Or Row = ACNcanBeAddRow Then Qty = Qty + 1 If Qty UBound(BlankRowAy) Then ReDim Preserve BlankRowAy(Qty) BlankRowAy(Qty) = Row End If Next Row For Ix = 1 To Qty If ChgRow = BlankRowAy(Ix) Then MsgBox "Invalid Row for Selection.", vbExclamation, Title If ChgRow < ACNcanBeAddRow Then ChgRow = ChgRow - 1 Else _ If ChgRow = ACNcanBeAddRow Then ChgRow = ChgRow + 1 Else _ ChgRow = ChgRow - 1 Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If Next Ix ' can't change draw directly Set ISect = Application.Intersect(DrawRng, Selection) If Not ISect Is Nothing Then DrawRng.Select MsgBox "Please change subscription or temp stops, NOT the draw.", _ vbExclamation, Title Range(Cells(ChgRow, SVrSubscrCol + COfs), _ Cells(ChgRow, SVrOthTScol + COfs)).Select GoTo Quit End If ' can't change key existing account data Set ISect = Application.Intersect(ExistACNrng, Selection) If Not ISect Is Nothing Then ExistACNrng.Select MsgBox "Data here can't be changed. Change subscription or temp stops.", _ vbExclamation, Title LastAddRng.Select MsgBox "OR ... ADD accounts in above cells," & Cr2 & "OR to add a " _ & "2nd or 3rd account, using these cells.", vbExclamation, Title Cells(ChgRow, SVrSubscrCol + COfs).Select GoTo Quit End If If ChgCol = iColA Then 'column A is no-man's land. Application.MoveAfterReturnDirection = xlToRight If PaBegRow <= ChgRow And ChgRow <= LastExistACNrow Then Cells(ChgRow, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ChgRow = ACNcanBeAddRow Then Cells(ChgRow + 1, SVrSubscrCol + COfs).Select ElseIf ACNcanBeAddRow < ChgRow And ChgRow <= LastAbrRow Then Cells(ChgRow, SVrDlvCol + COfs).Select ElseIf LastAbrRow < ChgRow And ChgRow <= PaEndRow Then Cells(ChgRow, SVrPaAbrCol + COfs).Select End If ElseIf ChgCol < (SVrSubNaCol + COfs) Then Application.MoveAfterReturnDirection = xlToRight ElseIf ChgCol = (SVrSubNaCol + COfs) Then 'rightmost allowable Application.MoveAfterReturnDirection = xlToLeft End If If ChgRow < HIrow And ChgCol < (SVrSubNaCol + COfs) Then MsgBox "Please select in only 1 row.", vbExclamation, Title Cells(ChgRow, ChgCol).Select End If Quit: Call SVC_Protect ' protects this sheet, enables events 'mainline end End Sub -- Dave Peterson -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Worksheet Change Event - copy cell to another sheet | Excel Discussion (Misc queries) | |||
Request macro code - when cell change event | Excel Programming | |||
Selection Change Event | Excel Programming | |||
Copy Sheets minus Worksheet Change Event code & Macro Buttons | Excel Programming |