Help Perfecting this Select Case code.

M

Mister H

Well-known Member
Joined
Mar 6, 2002
Messages
1,507
Hi All:

I am having some difficulties with a code that I am using. What the code is suppose to do is it looks in the cell in Column A and dependant on what is input there it locks or unlocks cells. This was working fine but now that I have altered the code it is not always working properly. I had altered the code so that you could copy down in column A and it would unlock cells. To make a long story short I am wondering if the code can be altered so that the beginning cell is ALWAYS column A prior to the code calculating the offset. So no matter which cell is active it will always look calculate the offset beginning with Column A.

I hope this makes sense

Here is the piece of code I am using:</SPAN>
Code: 
If Target.Row < 16 Then Exit Sub</SPAN>
  On Error Resume Next</SPAN>
 
  For Each cel In Intersect(Target, Target.SpecialCells(xlCellTypeConstants, xlTextValues))</SPAN>
    If cel.Row >= 16 Then cel.Value2 = UCase(cel.Value2)</SPAN>
    Select Case cel</SPAN>
        Case "AR", "AR-DIV", "AR-NSL"
[B]
[COLOR=#ff0000]'I am GUESSING something needs to be added here???[/COLOR][/B]</SPAN>[COLOR=#ff0000]   [/COLOR]         

cel.Offset(0, 9).Resize(1, 6).Locked = True</SPAN>
            cel.Offset(0, 17).Resize(1, 4).Locked = False</SPAN>
            ActiveSheet.CopyGLButton.Visible = False</SPAN>
 
        Case "NPC"</SPAN>
            cel.Offset(0, 10).Resize(1, 3).Locked = True</SPAN>
            cel.Offset(0, 14).Resize(1, 6).Locked = True</SPAN>
            ActiveSheet.CopyGLButton.Visible = False</SPAN>
 
        Case Else</SPAN>
            cel.Offset(0, 9).Resize(1, 6).Locked = False</SPAN>
            cel.Offset(0, 17).Resize(1, 4).Locked = False</SPAN>
            ActiveSheet.CopyGLButton.Visible = False</SPAN>
    End Select</SPAN>
Next cel</SPAN>

Any assistance as ALWAYS is APPRECIATED. :)

THANKS,
Mark
 
Last edited:

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
If you have range variable named "cel", in order to get to column A of the row that "cel" cell resides in, you could do that like this:
Code: 
Cells(cel.row,"A")
Does that help?
 
Upvote 0
What range is supposed to trigger this code?
 
Upvote 0
THANKS to BOTH of you for your replies. I think the code I have pieced together just does not want to function for me as I may be trying to do too much. The code is a Worksheet_Change code and it does function properly for most of the time the only thing that now seems to mess it up is that I have put a formula into Column A that populates</SPAN> the cell and now the Case code doesn't work. It does work if I manually change the value in column A but it does not work when the formula in cell A18 populates based on input in row 17 Formula in A18 is: =IF(T17>0,A17,"")

Basically I just wanted to have column A auto popoulate (with the ability for the user to change it) so that the user does not have to keep selecting the value there. SO if they are entering 20 AR's they only have to select AR once. Maybe I may have to just get rid of my formula.

Here is my entire probably messy code:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
[COLOR=#ff0000][B]' this code will undo PASTE and instead do a PASTE SPECIAL VALUES which will
' allow you to retain FORMATS in all of the cells in all of the sheets, but will
' also allow the user to COPY and PASTE data[/B][/COLOR]
    Dim UndoString As String
    Dim srce As Range
    On Error GoTo err_handler
    
If Target.Parent.Name <> "Input Sheet (2)" Then
    GoTo MyNext 'Exit Sub
End If
UndoString = Application.CommandBars("Standard").Controls("&Undo").List(1)
If Left(UndoString, 5) <> "Paste" And UndoString <> "Auto Fill" Then
    GoTo MyNext 'Exit Sub
End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
            
            
    If UndoString = "Auto Fill" Then
        
        Set srce = Selection
        
        srce.Copy
        
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
        Application.SendKeys "{ESC}"
        Union(Target, srce).Select
        
    Else
    
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    GoTo MyNext 'Exit Sub
err_handler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
MyNext:

[B][COLOR=#ff0000]'Change all entries to UPPERCASE
[/COLOR][/B]Dim cel As Range
  
    ActiveSheet.Protect "unlock", UserInterfaceOnly:=True
Application.EnableEvents = False
  If Target.Row < 16 Then Exit Sub
  On Error Resume Next
    
   
    For Each cel In Intersect(Target, Target.SpecialCells(xlCellTypeConstants, xlTextValues))
    If cel.Row >= 16 Then cel.Value2 = UCase(cel.Value2)
    
    
[COLOR=#ff0000][B]'Unlocks or Locks Cells based on Input in Column A
[/B][/COLOR]    Select Case Cells(cel.Row, "A")
        Case "AR", "AR-DIV", "AR-NSL"
            Cells(cel.Row, "A").Offset(0, 9).Resize(1, 6).Locked = True
            Cells(cel.Row, "A").Offset(0, 17).Resize(1, 4).Locked = False
            ActiveSheet.CopyGLButton.Visible = False
        Case "REV", "H-ER"
            Cells(cel.Row, "A").Offset(0, 17).Resize(1, 2).Locked = True
            Cells(cel.Row, "A").Offset(0, 9).Resize(1, 6).Locked = False
            Cells(cel.Row, "A").Offset(0, 19).Resize(1, 2).Locked = False
            ActiveSheet.CopyGLButton.Visible = ActiveCell.Row > 17
            With ActiveSheet.CopyGLButton
                .Top = ActiveCell.Top
                .Left = .Parent.Range("V1").Left
            End With
        Case "ER"
            Cells(cel.Row, "A").Offset(0, 9).Resize(1, 11).Locked = True
            ActiveSheet.CopyGLButton.Visible = False
        Case "NPC"
            Cells(cel.Row, "A").Offset(0, 10).Resize(1, 3).Locked = True
            Cells(cel.Row, "A").Offset(0, 14).Resize(1, 6).Locked = True
            ActiveSheet.CopyGLButton.Visible = False
        Case Else
            Cells(cel.Row, "A").Offset(0, 9).Resize(1, 6).Locked = False
            Cells(cel.Row, "A").Offset(0, 17).Resize(1, 4).Locked = False
            ActiveSheet.CopyGLButton.Visible = False
    End Select
Next cel
 
[COLOR=#ff0000][B]'autofit rows 17:266.  This range is named Autofit
[/B][/COLOR]    Range("Autofit").Rows.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

If you are still following my Garbled Post I am open for suggestions otherwise I will remove the formula and see if I can get it to function for them.


THANKS AGAIN,
Take Care,
Mark :)</SPAN>
 
Upvote 0
Mark

The result of a formula changing won't trigger the code, so you probably should remove it.

I've looked at the code and I think its garbled my mind.

There are some parts I dont quite get.

There also seem to be missing parts.

For example you don't check if the cell that has been changed is in column A.

Isn't that the column you want to 'monitor'?
 
Upvote 0
Hi Norie:

I don't quite get it either because I have just been adding pieces to it over the years. It started with just the Case portion of it. I thought this would take care of the Column A issue:

'Unlocks or Locks Cells based on Input in Column A
 Select Case Cells(cel.Row, "A")

Anyway, THANKS for looking and confirming the code is messed up. :LOL:

I guess I will head back to the drawing board remove the formula and see if the rest can function as required. :confused:

Take Care,
Mark
:)
 
Upvote 0
Mark

I don't see how this would work if column A hasn't been changed.
Code: 
Select Case Cells(cel.Row, "A")
If you want to check that it's column A that's been changed you can use something like this.
Code: 
If Target.Column<>1 Then Exit Sub
Anways, that's kind of irrelevant if you are going to start over.

If you do that, good luck.:)
 
Upvote 0
THANKS Norie. I will play around with your suggestions and see what I come up with. If I have to delete the formula it just meas that the user will have to enter a value in column A. It would have been a little more user friendly if Column A just auto populated with whatever the Row above contained but it doesn't seem that it is worth the headache. All I was trying to do was that if the user entered AR in A17 I wanted A18 to be AR as well.

Back to the drawing board... Maybe I can find a code that will do that for the user but I can search for that later.

Take Care,
Mark
 
Upvote 0
Hi Norie (or anyone that can assist):

I removed the formula to eliminate my problem and it seems to be working but I now notice that if I enter AR in cell A18 it unlocks the proper cells but if I then go and delete AR from A18 the Case Else does not trigger? I followed the code and it is showing cel = Nothing

Can the code below be fixed so that the Case Else triggers?

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' this code will undo PASTE and instead do a PASTE SPECIAL VALUES which will
' allow you to retain FORMATS in all of the cells in all of the sheets, but will
' also allow the user to COPY and PASTE data
    Dim UndoString As String
    Dim srce As Range
    On Error GoTo err_handler
    
If Target.Parent.Name <> "Input Sheet" Then
    GoTo MyNext 'Exit Sub
End If
UndoString = Application.CommandBars("Standard").Controls("&Undo").List(1)
If Left(UndoString, 5) <> "Paste" And UndoString <> "Auto Fill" Then
    GoTo MyNext 'Exit Sub
End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
            
            
    If UndoString = "Auto Fill" Then
        
        Set srce = Selection
        
        srce.Copy
        
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
        Application.SendKeys "{ESC}"
        Union(Target, srce).Select
        
    Else
    
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    GoTo MyNext 'Exit Sub
err_handler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
MyNext:
'Change all entries to UPPERCASE
Dim cel As Range
  
ActiveSheet.Protect "unlock", UserInterfaceOnly:=True
Application.EnableEvents = False
  If Target.Row < 16 Then Exit Sub
  On Error Resume Next
  
  For Each cel In Intersect(Target, Target.SpecialCells(xlCellTypeConstants, xlTextValues))
    If cel.Row >= 16 Then cel.Value2 = UCase(cel.Value2)
    Select Case cel
        Case "AR", "AR-DIV", "AR-NSL"
            cel.Offset(0, 9).Resize(1, 6).Locked = True
            cel.Offset(0, 17).Resize(1, 4).Locked = False
            ActiveSheet.CopyGLButton.Visible = False
        Case "REV", "H-ER"
            cel.Offset(0, 17).Resize(1, 2).Locked = True
            cel.Offset(0, 9).Resize(1, 6).Locked = False
            cel.Offset(0, 19).Resize(1, 2).Locked = False
            ActiveSheet.CopyGLButton.Visible = ActiveCell.Row > 17
            With ActiveSheet.CopyGLButton
                .Top = ActiveCell.Top
                .Left = .Parent.Range("V1").Left
            End With
        Case "ER"
            cel.Offset(0, 9).Resize(1, 11).Locked = True
            ActiveSheet.CopyGLButton.Visible = False
        Case "NPC"
            cel.Offset(0, 10).Resize(1, 3).Locked = True
            cel.Offset(0, 14).Resize(1, 6).Locked = True
            ActiveSheet.CopyGLButton.Visible = False
        [B][COLOR=#ff0000]Case Else
            cel.Offset(0, 9).Resize(1, 6).Locked = False
            cel.Offset(0, 17).Resize(1, 4).Locked = False
            ActiveSheet.CopyGLButton.Visible = False
[/COLOR][/B]    End Select
Next cel
 
'autofit rows 17:266.  This range is named Autofit
    Range("Autofit").Rows.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

THANKS,
Mark
 
Upvote 0
Mark

If you've deleted the value in the cell then I don't think SpecialCells will find it.

Why are you using SpecialCells anyway?
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Change Log With VBA
2
Replies
19
Views
630
Joe4
Joe4
C
  • Question
VBA Insert Picture Into Cell - Not working
Replies
7
Views
2K
sancarn
sancarn
N
  • Solved
Copy/paste a row from within a loop, before that loop moves on to next cell
Replies
5
Views
414
Joe4
Joe4
U
  • Question
Information overwriting when transferring
Replies
7
Views
390
UTB
U
E
  • Question
Adding a custom message.
Replies
1
Views
537
Micron
M

Forum statistics

Threads
1,219,162
Messages
6,146,660
Members
450,706
Latest member
LGVBPP

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top