Close Window   
Free Ebook
Get Your Free Excel
ebook!
Our Top 15 Excel Tutorials
Instant Access!
E-mail:
Subscribe for Free Excel tips & more!
E-mail:
Advertisements



Compile Error Ambiguous Name Detected

Forum Register
Search Excel Forum Posts, Tutorials, Macros, Tips, and More

Hello, Im using a script that allows me to autocomplete a data validation list using a combo box and the code shown below. However I am getting a compile error ambigous name detected and the following line is highlighted
"Private Sub Worksheet_SelectionChange(ByVal Target As Range)"

I know its because this is used twice but I am not sure what to do in order to fix this. I would appreciate some help on this.

Thank you.

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
  Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ws.OLEObjects("combobox1")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
Private Sub combobox1_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
On Error GoTo errHandler

If Target.Count > 1 Then GoTo exitHandler

Set cboTemp = ws.OLEObjects("combobox2")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

  On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If

exitHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
errHandler:
  Resume exitHandler

End Sub
Private Sub combobox2_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
On Error GoTo errHandler

If Target.Count > 1 Then GoTo exitHandler

Set cboTemp = ws.OLEObjects("combobox3")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

  On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If

exitHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
errHandler:
  Resume exitHandler

End Sub
Private Sub combobox3_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub



Private Sub CommandButton1_Click()
Range("C10").Select
    Selection.ClearContents
    Range("E14").Select
    Selection.ClearContents
    Range("G14").Select
    Selection.ClearContents
    Range("C12").Select
End Sub




View Answers     

Similar Excel Tutorials

Error bars in Charts in Excel
How to add, manage, and remove error bars in charts in Excel. Error bars allow you to show the potential variance ...
Prevent Errors From Appearing in Excel
How to prevent errors from appearing in formulas in Excel. This is especially helpful for the Vlookup function. Sec ...
Remove Vlookup #N/A Error in Excel
How to remove the #N/A error from Vlookup and replace it with a friendly message or a blank cell. Fix the Vlookup ...
Delete Blank Rows in Excel
This is a macro which will delete blank rows in excel. This version will delete an entire row if there is a blank ...

Helpful Excel Macros

Excel Macro to Save a Specific Worksheet as a New File
- This Excel Macro allows you to save a specific worksheet within the Excel Workbook to its own new file. You will be a
Save the Current Worksheet as a New Excel Workbook File
- This Excel Macro will save the currently visible/active worksheet (the one that you see when you run the macro) to a
Complete Guide to Printing in Excel Macros - PrintOut Method in Excel
- This free Excel macro illustrates all of the possible parameters and arguments that you can include in the PrintOut Meth
Macro to add a New Line to Message Box Pop-up Windows in Excel
- This is a very simple Message Box, pop-up window, macro for Excel that illustrates how to put new lines, the same thi
Excel Macro that Searches Entire Workbook and Returns All Matches
- This is the ultimate Lookup Macro for Excel. It will search every worksheet in the workbook and return all of the mat

Similar Topics







Hi there,

I have quite a few things going on. I need to know how to incorp Code:

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
  Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

End Sub

'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

errHandler:

  Application.EnableEvents = True
  Exit Sub

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================


With the following code

Code:

 If Target.Cells.Count = 1 And Not (Application.Intersect(Target, Range("A1:D100")) Is Nothing) Then
        If 1 < Application.CountIf(Range("a1:D100"), Target.Value) Then
            Application.EnableEvents = False
                MsgBox Target.Value & " Already Has a Shift on " & ActiveSheet.Name & "!", vbCritical, "WARNING!"
                
                Target.ClearContents
                
            Application.EnableEvents = True
        End If
    End If


Both Codes need to work together.


I'm having a problem with the screen flickering whenever a different cell is selected due to a ComboBox. I searched the forums and wasn't able to find any code that helped my problem. The fact that I wouldn't know where to insert the proper code to fix it even if I could find it doesn't help. That's why I assume the "optional code" listed at the end that I found online does not work properly because it probably isn't in the right spot. Any help would be appreciated. Here's the code:

Code:

'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
On Error GoTo errHandler

If Target.Count > 1 Then GoTo exitHandler

Set cboTemp = ws.OLEObjects("Staff4Combo")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

  On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 22
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If

exitHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
errHandler:
  Resume exitHandler

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================





I would like to combine the two Worksheet_SelectionChange statements into 1 to avoid the "Compile error: Ambiguous name detected" error that I have caused.

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
     'The 1st method is coded to launch when a curtain cell is  selected
    If Target.Address = "$G$8" Or Target.Address = "$G$14" Or Target.Address = "$G$17" Then 
        CalendarFrm.Show 
    End If 
     'another method is to have it show if a cell that is formatted as a date is selected...see below
    If Target.NumberFormat = "m/d/yy;@" Then 
        CalendarFrm.Show 
    End If 
     'another method is using Select Case...see below
    Select Case Target.NumberFormat 
    Case Is = "m/d/yy", "m/d/yyyy", "m/d/yy", "mm/dd/yy", "yyyy-mmm-dd" 
        CalendarFrm.Show 
         'Case Else
         '    MsgBox "Not a valid date format!"
    End Select 
End SubOption Explicit 
Private Sub Calendar1_Click() 
End Sub 
Private Sub TempCombo_KeyDown(ByVal _ 
    KeyCode As MSForms.ReturnInteger, _ 
    ByVal Shift As Integer) 
     'Hide combo box and move to next cell on Enter and Tab
    Select Case KeyCode 
    Case 9 
        ActiveCell.Offset(0, 1).Activate 
    Case 13 
        ActiveCell.Offset(1, 0).Activate 
    Case Else 
         'do nothing
    End Select 
End Sub 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 
    On Error Goto errHandler 
    If Target.Count > 1 Then Goto exitHandler 
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    If cboTemp.Visible = True Then 
        With cboTemp 
            .Top = 10 
            .Left = 10 
            .ListFillRange = "" 
            .LinkedCell = "" 
            .Visible = False 
            .Value = "" 
        End With 
    End If 
    On Error Goto errHandler 
    If Target.Validation.Type = 3 Then 
        Application.EnableEvents = False 
        str = Target.Validation.Formula1 
        str = Right(str, Len(str) - 1) 
        With cboTemp 
            .Visible = True 
            .Left = Target.Left 
            .Top = Target.Top 
            .Width = Target.Width + 15 
            .Height = Target.Height + 5 
            .ListFillRange = ws.Range(str).Address 
            .LinkedCell = Target.Address 
        End With 
        cboTemp.Activate 
    End If 
exitHandler: 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
    Exit Sub 
errHandler: 
    Resume exitHandler 
End Sub 
 
[B][/B] 


If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines




Hi All,
I found the below code on http://www.contextures.com/xlDataVal10.html and it seems to work great EXCEPT when I put a named range where the data is on another sheet. When the named range is on the same sheet it works.
What I am trying to do is expand the length of the driop down list.
Does anyone have a clue how I can make it work with the named range on a seperate sheet? If you do, can you explain to me why so I can learn.
Thank you very much.
Warren

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
'if the cell contains a data validation list
Application.EnableEvents = False
'get the data validation formula
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
'show the combobox with the list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = ws.Range(str).Address
.LinkedCell = Target.Address
End With
cboTemp.Activate
End If

errHandler:
Application.EnableEvents = True
Exit Sub

End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
If cboTemp.Visible = True Then
With cboTemp
.Top = 10
.Left = 10
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If

errHandler:
Application.EnableEvents = True
Exit Sub

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub


I have the following code frm http://www.contextures.com/xlDataVal11.html

The problem with the below code is while entering data in combobox, any data(outside defined list) is allowed where i need to allow only the data from defined list. An error/warning should popup while entering data from out of the dropdown list.

Where do i change the code for this functionality?

Thanks.

Code:

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
  Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets("ValidationLists")

Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = True

If Application.CutCopyMode Then
  'allow copying and pasting on the worksheet
  GoTo errHandler
End If

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With

errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub 
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab 
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter 
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================





PHP Code:

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
  Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = ws.Range(str).Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 13 'Enter
            ActiveCell.Offset(0, 1).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$Z$3:$AA$3" Then
Call GoToMatch
End If
End Sub
==================================== 





Compile error:
Ambiguous name detected: Worksheet_SelectionChange

this error occurs and higlights the line Private Sub Worksheet_SelectionChange(ByVal Target As Range) which belongs to the last Private Sub that is:-
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$Z$3:$AA$3" Then
Call GoToMatch
End If
End Sub

any help will be appreciated...


Basically i'm building a database in access with all the data handling done across a network in excel.(both 2007) Current problem is validation.

The plan is to have code that takes a validated cell i.e. one that has a list associated with it from the excel built in validation tool and populate a temp combo box with that list, this means that every time a cell is selected a validated list can be chosen from, as well as this as the text is typed in the list is autocompleted!..

i had this working for one sheet, but when i try to create a new instance of it in a new worksheet it fails..

can anyone tell me why?

thanks

Jonathan

Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
'Dim wsList As Worksheet
Set ws = ActiveSheet
On Error GoTo errhandler
'Set wsList = Sheets("ValidationLists")


If Target.count > 1 Then GoTo exitHandler

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End If

  On Error GoTo errhandler
  If Target.Validation.Type = 3 Then
    'if the cell contains a data validation list
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If

exitHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
errhandler:
  Resume exitHandler

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    Select Case KeyCode
        Case 9 'Tab
            ActiveCell.Offset(0, 1).Activate
        Case 13 'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub


update..

turns out all that needs to be done was renaming a combo box "TempCombo".. not a clue how i missed this.. wasted the better part of a day.. anyway, feel free to use the code if it's helpful fo you, originally from http://www.contextures.com/


I am looking for assisitance in combining the functionality of two seperate combo box code sets. The first combo box code set allows the combo box to automaticially appear when a user Clicks on a cell that contains a data validation list. The second set of code will have a combo box appear when a user Double-clicks on a cell that contains a data validation list. And the code allows for Named Ranges on a seperate worksheet.

I would like to have the functionality of having the combo box to appear when a user Clicks on a cell and not having to Double-click. Also, I would like to have the option to use Named Ranges on a seperate worksheet ("Validation Lists").

I would appreciate any assistance that can be given. Thank you! The code for both sets is listed below.

Data Validation -- Combo box -- Click
VB:

 '=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 
    On Error Goto errHandler 
     
    If Target.Count > 1 Then Goto exitHandler 
     
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    If cboTemp.Visible = True Then 
        With cboTemp 
            .Top = 10 
            .Left = 10 
            .ListFillRange = "" 
            .LinkedCell = "" 
            .Visible = False 
            .Value = "" 
        End With 
    End If 
     
    On Error Goto errHandler 
    If Target.Validation.Type = 3 Then 
         'if the cell contains a data validation list
        Application.EnableEvents = False 
         'get the data validation formula
        str = Target.Validation.Formula1 
        str = Right(str, Len(str) - 1) 
        With cboTemp 
             'show the combobox with the list
            .Visible = True 
            .Left = Target.Left 
            .Top = Target.Top 
            .Width = Target.Width + 15 
            .Height = Target.Height + 5 
            .ListFillRange = ws.Range(str).Address 
            .LinkedCell = Target.Address 
        End With 
        cboTemp.Activate 
    End If 
     
exitHandler: 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
    Exit Sub 
errHandler: 
    Resume exitHandler 
     
End Sub 
 '====================================
 'Optional code to move to next cell if Tab or Enter are pressed
 'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _ 
    KeyCode As MSForms.ReturnInteger, _ 
    ByVal Shift As Integer) 
    Select Case KeyCode 
    Case 9 'Tab
        ActiveCell.Offset(0, 1).Activate 
    Case 13 'Enter
        ActiveCell.Offset(1, 0).Activate 
    Case Else 
         'do nothing
    End Select 
End Sub 
 '====================================


If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines




Data Validation -- Combo box using Named Ranges

VB:

 '==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ 
    Cancel As Boolean) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Dim wsList As Worksheet 
    Set ws = ActiveSheet 
    Set wsList = Sheets("ValidationLists") 
     
    Cancel = True 
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    With cboTemp 
         'clear and hide the combo box
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
    End With 
    On Error Goto errHandler 
    If Target.Validation.Type = 3 Then 
         'if the cell contains a data validation list
        Application.EnableEvents = False 
         'get the data validation formula
        str = Target.Validation.Formula1 
        str = Right(str, Len(str) - 1) 
        With cboTemp 
             'show the combobox with the list
            .Visible = True 
            .Left = Target.Left 
            .Top = Target.Top 
            .Width = Target.Width + 5 
            .Height = Target.Height + 5 
            .ListFillRange = str 
            .LinkedCell = Target.Address 
        End With 
        cboTemp.Activate 
    End If 
     
errHandler: 
    Application.EnableEvents = True 
    Exit Sub 
     
End Sub 
 '=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 
    Application.EnableEvents = False 
    Application.ScreenUpdating = True 
     
    If Application.CutCopyMode Then 
         'allow copying and pasting on the worksheet
        Goto errHandler 
    End If 
     
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    With cboTemp 
        .Top = 10 
        .Left = 10 
        .Width = 0 
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
        .Value = "" 
    End With 
     
errHandler: 
    Application.EnableEvents = True 
    Exit Sub 
     
End Sub '====================================
 'Optional code to move to next cell if Tab or Enter are pressed
 'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _ 
    KeyCode As MSForms.ReturnInteger, _ 
    ByVal Shift As Integer) 
    Select Case KeyCode 
    Case 9 'Tab
        ActiveCell.Offset(0, 1).Activate 
    Case 13 'Enter
        ActiveCell.Offset(1, 0).Activate 
    Case Else 
         'do nothing
    End Select 
End Sub 
 '====================================


If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines




I'm using Excel 2010 and have created several long data validation lists with named ranges on separate sheets from where the drop down lists are. I have tried to allow autocomplete functionality by following the directions found at http://www.contextures.com/xlDataVal11.html.

Unfortunately my vba experience is about zero! I'm guessing that I need to modify some names/ranges/sheets etc, etc but I have no idea which bits are the critical bits. I named my combo box as ComboBox01. The sheet one particular set of data is on is AKLD_DATA. The range the the data validation references is AUCKLAND.

Can anyone please tell me which bits in the below I need to change?

My exact copy and paste was:

'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets("ValidationLists")

Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
'if the cell contains a data validation list
Application.EnableEvents = False
'get the data validation formula
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
'show the combobox with the list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
End If

errHandler:
Application.EnableEvents = True
Exit Sub

End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = True

If Application.CutCopyMode Then
'allow copying and pasting on the worksheet
GoTo errHandler
End If

Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With

errHandler:
Application.EnableEvents = True
Exit Sub

End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
Private Sub TempCombo_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub
'====================================



I'm trying to use a combo box with my data validation. It works great when I'm not using the the INDIRECT function for the validation. But I can't get it to work with it.

I downloaded the code from the internet.

What it does when i don't use the INDIRECT function: I click on a cell that has a Data Validation assigned to it, it activates the combo box to be visible by just clicking on the cell one time, and it auto fills when i start typing. And when I click on the drop down, it list all my options that I can select.

What it does when i use the INDIRECT function: I click on a cell that has a Data Validation assigned to it, it activates the combo box to be visible by just clicking on the cell one time, but it does not auto fill when i start typing. And when I click on the drop down, it does not list any options.

I was wondering if i can add/change something to the code to make it work?

I am also wondering if I can make the combo box expand when i click on the cell?

This is the code:

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Dim wsList As Worksheet 
    Set ws = ActiveSheet 
    Set wsList = Sheets("Order Form") 
     
    Cancel = True 
    Set cboTemp = ws.OLEObjects("FenceSelection") 
    On Error Resume Next 
    With cboTemp 
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
    End With 
    On Error Goto errHandler 
    If Target.Validation.Type = 3 Then 
        Application.EnableEvents = False 
        str = Target.Validation.Formula1 
        str = Right(str, Len(str) - 1) 
        With cboTemp 
            .Visible = True 
            .Left = Target.Left 
            .Top = Target.Top 
            .Width = Target.Width + 3 
            .Height = Target.Height + 3 
            .ListFillRange = str 
            .LinkedCell = Target.Address 
        End With 
        cboTemp.Activate 
    End If 
     
errHandler: 
    Application.EnableEvents = True 
    Exit Sub 
End Sub 
Private Sub Worksheet(ByVal Target As Range) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 
    Application.EnableEvents = False 
    Application.ScreenUpdating = True 
     
    Set cboTemp = ws.OLEObjects("FenceSelection") 
    On Error Resume Next 
    With cboTemp 
        .Top = 10 
        .Left = 10 
        .Width = 0 
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
        .Value = "" 
    End With 
     
errHandler: 
    Application.EnableEvents = True 
    Exit Sub 
End Sub 
 
 
Private Sub FenceSelection_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 
    Select Case KeyCode 
    Case 9 
        ActiveCell.Offset(0, 1).Activate 
    Case 13 
        ActiveCell.Offset(1, 0).Activate 
    Case Else 
    End Select 
End Sub 


If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines




hello again,

I'm still trying to tune up my combo box, and as I test it, I find
things that need some work to make it smooth. I would like to have it
setup so that the mouse is not required for data entry. It can be used
as an option, just not a required tool.

How do I add a shortcut key to the following code: (This code is in
sheet1)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel
As Boolean)

Dim ws As Worksheet
Set ws = ActiveSheet

Dim cboTemp As OLEObject
Cancel = True
Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Column = 2 And ActiveSheet.Name = "Timesheet Entry"
Then
Application.EnableEvents = False
With cboTemp
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 275
.Height = Target.Height + 5
.LinkedCell = Target.Address
End With
cboTemp.Activate
End If

errHandler:
Application.EnableEvents = True
Exit Sub

End Sub

I've added this line:

Keyboard Shortcut: Ctrl Shift + Z

Without success. I've written a sub to call the doubleclick sub and
attached a shortcut there, to no avail.

If anyone can help, I'd really appreciate it.

Thanks,

Dave




Hi there,

Here's the issue I'm hoping someone can help with (I've pieced the solution together from some code I found he http://www.contextures.com/xlDataVal14.html
That link explains how to insert a combo box in fields that are using data validation from a list (to take advantage of combobox feature over the default drop down in excel). I changed that code to insert MS Date Picker instead of a combobox if the data validation is set to Date

Here is my code:
Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
On Error GoTo errHandler

If Target.Count > 1 Then GoTo exitHandler

Set cboTemp = ws.OLEObjects("DPick")
On Error Resume Next
If cboTemp.Visible = True Then
  With cboTemp
    .Top = 10
    .Left = 10
    .LinkedCell = ""
    .Visible = False
    
  End With
End If

  On Error GoTo errHandler
  If Target.Validation.Type = 4 Then
    'if the cell contains a data validation date
    Application.EnableEvents = False
    
    Target.NumberFormat = "mm/dd/yyyy" 'format the cell to a date
    
    DPick.Value = Date 'default date picker to today if field is blank
    
    With cboTemp
      'show the Date Picker
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    
  End If

exitHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
errHandler:
  Resume exitHandler

End Sub


I have 2 problems:

#1 If the field is blank, the date picker default to today (Great!) but if try to accept that value and move to a new cell the last cell remains blank
#2 once you choose a date value with the date picker, the cell shows a Data Validation error - it seems the value is a string (left justified) - selecting the cell, F2 then Enter corrects the issue.

Can anyone help with these issues please?


Howdy all,

I have been struggling with trying to figure this out.

Problem: When entering text into cells on the "Back Page" the previous value of the cell is lost.

Example: Enter information into one of the "Charge" fields on the back of the form. Select another cell and then try to edit the existing value of the field.

I have included a link to the file that is located on a governement website. I have also included all of the worksheet code.

The file and workbook is password protected. If you send me a private message and think you can help then I will send you the password.

The operation of this file affects approximatley 12,000 police officers in the State of Texas. Your help is appreciated.

I am hoping this something that I am just overlooking because I am tired...

ftp://ftp.dot.state.tx.us/pub/txdot-...ments/cr_3.xls


Code:

Private Sub Worksheet_Activate()
    Dim X                               As Integer
    Application.ScreenUpdating = False
    Application.Run "SetZoom"
    Application.Run "unlock_narrative"
    X = ActiveWindow.Zoom
    With Application
        .Cursor = xlNorthwestArrow
    End With
    With Worksheets("Back Page")
        Application.CommandBars("Drawing").Visible = False
    End With
    If Application.Version = "12.0" Then GoTo Skipfor12
    With ActiveSheet.Shapes("Narrative")
        .Left = Range("BP_Narrative").Left + 2
        .Top = Range("BP_Narrative").Top + 2
        .Width = 272
        .Height = 272
    End With
Skipfor12:
    With ActiveWindow
        .DisplayGridlines = False
        .DisplayHeadings = False
    End With
    If Application.Version = "12.0" Then
        ActiveWindow.Zoom = X + 1
        ActiveWindow.Zoom = X - 1
    End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("BP_CheckBoxes")) Is Nothing Then    ' You can Change the range here
        Cancel = True
        If Target.Cells(1, 1).Value = "" Then
            Target.Cells(1, 1).Value = "X"
        Else
            Target.Cells(1, 1).Value = ""
        End If
    End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
                                       Cancel As Boolean)
    Dim Str                             As String
    Dim cboTemp                         As OLEObject
    Dim ws                              As Worksheet
    Dim wsList                          As Worksheet
    Set ws = Sheets("Back Page")
    Set wsList = Sheets("ValidationLists")
    Set cboTemp = ws.OLEObjects("TempCombo1")
    On Error Resume Next
    With cboTemp
        'clear and hide the combo box
        .ListFillRange = ""
        .LinkedCell = ""
        .Visible = False
    End With
    On Error GoTo ErrHandler
    If Target.Validation.Type = 3 Then
        Cancel = True
        'if the cell contains a data validation list
        Application.EnableEvents = False
        'get the data validation formula
        Str = Target.Validation.Formula1
        Str = Right(Str, Len(Str) - 1)
        With cboTemp
            'show the combobox with the list
            .Visible = True
            .Left = Target.Left + 2
            .Top = Target.Top + 2
            .Width = Target.Width + 12
            .Height = Target.Height - 2
            .ListFillRange = (Str) & "1"
            .LinkedCell = Target.Address
            .BackColor.RGB = RGB(0, 0, 0)
        End With
        cboTemp.Activate
    End If
ErrHandler:
    Application.EnableEvents = True
    Exit Sub
End Sub
Private Sub Worksheet_Deactivate()
    Dim NarrativeText                   As String
    NarrativeText = Worksheets("Back Page").Shapes("Narrative").TextFrame.Characters.Text
    If Application.Version = "12.0" Then
        If NarrativeText = "" Then
            Worksheets("Back Page").Shapes("Narrative").TextFrame.Characters.Text = "Click here to type narrative."
        End If
    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Str                             As String
    Dim cboTemp                         As OLEObject
    Dim ws                              As Worksheet
    Set ws = Sheets("Back Page")
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If Application.CutCopyMode Then
        'allow copying and pasting on the worksheet
        GoTo ErrHandler
    End If
    Set cboTemp = ws.OLEObjects("TempCombo1")
    On Error Resume Next
    With cboTemp
        .Top = 10
        .Left = 10
        .Width = 0
        .ListFillRange = ""
        .LinkedCell = ""
        .Visible = False
        .Value = ""
        .BackColor.RGB = RGB(0, 0, 0)
        Range("List").Value = ""
    End With
    '============================================================
    ' Custom Tab Order
    Dim X                               As String
    Select Case ActiveCell.Address
            '***** Disposition of Killed and Injured
        Case "$BE$7"
            Application.OnKey "{TAB}", "ToDIP2"
        Case "$BE$9"
            Application.OnKey "{TAB}", "ToDIP3"
        Case "$BE$11"
            Application.OnKey "{TAB}", "ToDIP4"
        Case "$BE$13"
            Application.OnKey "{TAB}", "ToDIP5"
        Case "$BE$15"
            Application.OnKey "{TAB}", "ToDIP6"
        Case "$BE$17"
            Application.OnKey "{TAB}", "ToCharge"
        Case "$DA$26"
            Application.OnKey "{TAB}", "ToCarrCorpName"
        Case "$EO$30"
            Application.OnKey "{TAB}", "ToCargoBodyStyle"
        Case "$EJ$35"
            Application.OnKey "{TAB}", "ToSeq"
        Case "$EJ$44"
            Application.OnKey "{TAB}", "ToHowNotified"
        Case "$DN$53"
            Application.OnKey "{TAB}", "ToORI"
        Case "$AL$51"
            Application.OnKey "{TAB}", "ToReportDate"
        Case "$EM$58"
            Application.OnKey "{TAB}", "ToBackTop"
            '***** ELSE
        Case Else
            Application.OnKey "{TAB}", "ToNext"
    End Select
    '============================================================
ErrHandler:
    Application.EnableEvents = True
    Exit Sub
End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
Private Sub TempCombo1_KeyDown(ByVal _
                               KeyCode As MSForms.ReturnInteger, _
                               ByVal Shift As Integer)
    Select Case KeyCode
        Case 9                                        'Tab
            ActiveCell.Offset(0, 0).Activate
            SendKeys "{TAB}"
        Case 13                                       'Enter
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
'====================================


Any help or suggestions are appreciated!

Patrick


I want the combobox list to automatically drop down when the activecell is in column 1. This code does not cause the drop down event to occur when the activecell is reached. Why not?

Code:

 

Private Sub ComboBox1_Click()
ActiveCell.Offset(0, 1).value = WorksheetFunction.Index(Range("MYRANGE"), ComboBox1.ListIndex + 1, 2)
'ActiveCell.Offset(0, 1).value = _
'WorksheetFunction.Index(Sheets("MYLIST").Range("a1:b14"), _
'    ComboBox1.ListIndex + 1, 2)
ActiveCell.Offset(0, 2).value = Date
ActiveCell.Offset(0, 3).value = "Autodeb"
ActiveCell.Offset(0, 4).Select
Debit.Show
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-4).Activate

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cboTemp As OLEObject
Set ws = Worksheets("MYLIST")
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ActiveSheet.OLEObjects("ComboBox1")
  On Error Resume Next
If Target.Column = 1 Then
    With cboTemp
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 3
      .ListFillRange = ws.Range("MYRANGE").Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    ComboBox1.DropDown
Else
  With cboTemp
  .ListFillRange = ""
  .LinkedCell = ""
  .Visible = False
  End With
End If
End Sub



Thanks if you can help.

CR


I have two lines of code that work perfectly when only one exist. When entering both I am prompted with the error message "Ambiguous Name" referring to Private Sub Worksheet_Change. I have been staring my screen for 3 hours now and can't seem to figure it out

Any help is very very appreciated! Thanks everyone, and by the way this is my first post, I look forward to learning from you all, as I have already just by reading through the forum!

Below are my two codes.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 4 Then
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
      Target.Value = oldVal _
        & ", " & newVal
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub


Code:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim wsLists As Worksheet
Dim PartNoRow As Long
Dim PartDescRow As Long

On Error GoTo errHandler
Set wsLists = Worksheets("Lists")

If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False

Select Case Target.Column
  Case 1
    With Target
      If .Value = "" Then
        .Offset(0, 1).Value = ""
      Else
        PartNoRow = Application.Match(.Value, wsLists.Range("PartNo"), 0)
        .Offset(0, 1).Value = wsLists.Range("PartDesc")(PartNoRow).Value
      End If
    End With
  Case 2
    With Target
      If .Value = "" Then
        .Offset(0, -1).Value = ""
      Else
        PartDescRow = Application.Match(.Value, wsLists.Range("PartDesc"), 0)
        .Offset(0, -1).Value = wsLists.Range("PartNo")(PartDescRow).Value
      End If
    End With
  Case Else
    'do nothing
End Select

exitHandler:
  Application.EnableEvents = True
  Exit Sub
errHandler:
  MsgBox Err.Number & ": " & Err.Description
  GoTo exitHandler

End Sub





I am using two of these codes for a worksheet that needs them both. However, the second one does not work when it is in with the first. It does work alone.
Is there a way I can use these together?

Thanks, Tawnee.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 29 Then Exit Sub

On Error GoTo errhandler
Application.EnableEvents = False
With Target.Offset(5, 5)
If .Value = "" Then
.Value = "X"
Else
.Value = ""
End If
End With

errhandler:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

If ActiveCell.Address = "$A$1" Then

ActiveWorkbook.SaveAs FileName:="\\DTCNAS-ILSP002\Pricing\ExtendedLockCompleted\" & ActiveSheet.Range("as32")

Else
'Do Nothing
End If

End Sub


I'm new to the forum and scripting/Macro Excel. I have a calculation sheet that the user inputs weight by pounds into a cell (G5), then in the cells following (H5, I5, J5, L5, M5, N5), the user inputs ounces. With the following code this allows me to have the user input ounces in one cell (H5) and then a percentage is calculated and outputted into the same cell (H5). Basically the formula is simple, oz. x 0.0625 / lbs. * 10. I found this code on the web, modified it and it worked great. Now I've added a little more to the formula and I get "Procedure too large". Not surprising I guess. HELP!!

Here's my code:
Code:

Public Sub Worksheet_Change(ByVal Target As Range)


'---BEGIN ROW 5 ---------------------------------------------------------------------------
If Range("G5").Value <> "" Then

    Select Case Target.Address
        
        Case "$I$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True

        Case "$J$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
            
        Case "$L$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True

        Case "$N$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
        
        Case "$P$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
        
        Case "$R$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
            
        Case "$S$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
            
        Case "$T$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
        
        Case "$U$5"
            Application.EnableEvents = False
            Range(Target.Address).Value = Range(Target.Address).Value * 0.0625 / Range("G5").Value * 100
            Application.EnableEvents = True
        
        Case Else
            'reenable events
            Application.EnableEvents = True
            
        End Select
End If


'---BEGIN ROW 6---------------This is a little older code------------------------------------------------------


If Range("G6").Value <> "" Then

    Select Case Target.Address
          
        Case "$I$6"
            Application.EnableEvents = False
            Range("I6").Value = Range("I6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True

        Case "$J$6"
            Application.EnableEvents = False
            Range("J6").Value = Range("J6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
            
        Case "$L$6"
            Application.EnableEvents = False
            Range("L6").Value = Range("L6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True

        Case "$R$6"
            Application.EnableEvents = False
            Range("R6").Value = Range("R6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
 
        Case "$N$6"
            Application.EnableEvents = False
            Range("N6").Value = Range("N6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True

        Case "$P$6"
            Application.EnableEvents = False
            Range("P6").Value = Range("P6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
          
        Case "$S$6"
            Application.EnableEvents = False
            Range("S6").Value = Range("S6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
            
        Case "$T$6"
            Application.EnableEvents = False
            Range("T6").Value = Range("T6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
        
        Case "$U$6"
            Application.EnableEvents = False
            Range("U6").Value = Range("U6").Value * 0.0625 / Range("G6").Value * 100
            Application.EnableEvents = True
        
        Case Else
            'reenable events
            Application.EnableEvents = True
            
        End Select
End If

And so on with rows following.


Exit Sub
'error handler
ErrMnd:
Err.Clear
'reenable events
Application.EnableEvents = True
End Sub




Every time I try to simplify I get errors. I would appreciate help, a litle frustrated at the moment.

Thank you


I would like all three of the code sets (Below) to work on one sheet.
Can some edit my codes to do this, or tell me how. I am very new to this and only have these codes thank to the nice people on here!
Thanks / Rich

------------------------------------------
Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const WS_RANGE As String = "b5:e6" '<=== change Range of cells to suit

    On Error GoTo err_handler
    Application.EnableEvents = False
    If Not Application.Intersect(Target, Range(WS_RANGE)) Is Nothing Then
        With Target
            .Font.Name = "X"
            Select Case .Value
                Case "X":   .Value = "N/A"
                Case "N/A":   .Value = "Z"
                Case "Z":   .Value = ""
                Case "":   .Value = "X"
                Case Else:   .Value = ""
                
            End Select
            .Offset(2, 0).Select
        End With
    End If
err_handler:
    Application.EnableEvents = True
End Sub
--------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const WS_RANGE As String = "b23:e24" '<=== change to suit
If ActiveCell.Offset(0, -1).Value <> "w" Then
Exit Sub
End If
    On Error GoTo err_handler
    Application.EnableEvents = False
    If Not Application.Intersect(Target, Range(WS_RANGE)) Is Nothing Then
        With Target
            .Font.Name = "Red"
            Select Case .Value
                Case "Red":   .Value = "White"
                 Case "White":   .Value = "Blue"
                  Case "Blue":   .Value = ""
                Case Else:   .Value = "Red"
                
            End Select
            .Offset(2, 0).Select
        End With
    End If
err_handler:
    Application.EnableEvents = True
End Sub
---------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const WS_RANGE As String = "b20:e21" '<=== change to suit
If ActiveCell.Offset(0, -1).Value <> "q" Then
Exit Sub
End If
    On Error GoTo err_handler
    Application.EnableEvents = False
    If Not Application.Intersect(Target, Range(WS_RANGE)) Is Nothing Then
        With Target
            .Font.Name = "Yes"
            Select Case .Value
                Case "Yes":   .Value = "No"
                 Case "No":   .Value = "Maybe"
                  Case "Maybe":   .Value = ""
                Case Else:   .Value = "Yes"
                
            End Select
            .Offset(2, 0).Select
        End With
    End If
err_handler:
    Application.EnableEvents = True
End Sub





Hi,

I'm creating a small spreadsheet for client data in Excel and I want it formatted a certain way, I did consider data validation but it proved to just be annoying.

I've been working on some VBA code to automatically change whatever text is typed into a cell to the correct case (ucase, lcase or proper) and while I can get it working for a single range of cells getting it to work for more is proving difficult.

This is what I have so far;
Code:

Private Sub Worksheet_change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then
        Exit Sub
    End If
    On Error GoTo ErrHandler:
    
    Select Case Target
    
    Case Range("C2:C65535")
    
    If Not Application.Intersect(Me.Range("C2:C65535"), Target) Is Nothing Then
        If IsNumeric(Target.Value) = False Then
            Application.EnableEvents = False
            'Target.Value = StrConv(Target.Text, vbLowerCase)
            Target.Value = StrConv(Target.Text, vbUpperCase)
            'Target.Value = StrConv(Target.Text, vbProperCase)
            Application.EnableEvents = True
        End If
    End If
    
    Case Range("D2:D65535")
    
    If Not Application.Intersect(Me.Range("D2:D65535"), Target) Is Nothing Then
        If IsNumeric(Target.Value) = False Then
            Application.EnableEvents = False
            'Target.Value = StrConv(Target.Text, vbLowerCase)
            Target.Value = StrConv(Target.Text, vbUpperCase)
            'Target.Value = StrConv(Target.Text, vbProperCase)
            Application.EnableEvents = True
        End If
    End If
    
    Case Range("B2:B65535")
    
    If Not Application.Intersect(Me.Range("D2:D65535"), Target) Is Nothing Then
        If IsNumeric(Target.Value) = False Then
            Application.EnableEvents = False
            'Target.Value = StrConv(Target.Text, vbLowerCase)
            'Target.Value = StrConv(Target.Text, vbUpperCase)
            Target.Value = StrConv(Target.Text, vbProperCase)
            Application.EnableEvents = True
        End If
    End If
    
    End Select
ErrHandler:
    Application.EnableEvents = True
    
    
End Sub





I have added some code, and upon doing so I am now prompted with the following Run time error 1004 Method 'Undo of object' Application Failed, when I click the debug button, Application.Undo is highlighed? Please Help I have been working at this now for around 6 hour!!! Thanks Everyone!

VB:

 
Private Sub Worksheet_Change(ByVal Target As Range) 
    Application.EnableEvents = False 
    newVal = Target.Value 
    Application.Undo 
    oldVal = Target.Value 
    Target.Value = newVal 
    If Target.Column = 4 Then 
        If oldVal = "" Then 
             'do nothing
        Else 
            If newVal = "" Then 
                 'do nothing
            Else 
                Target.Value = oldVal _ 
                & ", " & newVal 
            End If 
        End If 
    End If 
    Dim wsLists As Worksheet 
    Dim PartCoRow As Long 
    Dim PartNaRow As Long 
    Dim PartdeRow As Long 
    On Error Goto errHandler 
    Set wsLists = Worksheets("Lists") 
    If Target.Count > 1 Then Exit Sub 
    Application.EnableEvents = False 
    Select Case Target.Column 
    Case 1 
        With Target 
            If .Value = "" Then 
                .Offset(0, 1).Value = "" 
                .Offset(0, 3).Value = "" 
            Else 
                PartCoRow = Application.Match(.Value, wsLists.Range("PartCo"), 0) 
                .Offset(0, 1).Value = wsLists.Range("PartNa")(PartCoRow).Value 
                .Offset(0, 3).Value = wsLists.Range("PartDe")(PartCoRow).Value 
            End If 
        End With 
    Case 2 
        With Target 
            If .Value = "" Then 
                .Offset(0, -1).Value = "" 
                .Offset(0, 2).Value = "" 
            Else 
                PartNaRow = Application.Match(.Value, wsLists.Range("PartNa"), 0) 
                .Offset(0, -1).Value = wsLists.Range("PartCo")(PartNaRow).Value 
                .Offset(0, 2).Value = wsLists.Range("PartDe")(PartNaRow).Value 
            End If 
        End With 
    Case 3 
        With Target 
            If .Value = "" Then 
                .Offset(0, -3).Value = "" 
                .Offset(0, -2).Value = "" 
            Else 
                PartdeRow = Application.Match(.Value, wsLists.Range("PartDe"), 0) 
                .Offset(0, -1).Value = wsLists.Range("PartCo")(PartdeRow).Value 
                .Offset(0, 1).Value = wsLists.Range("PartNa")(PartdeRow).Value 
            End If 
        End With 
    Case Else 
         'do nothing
    End Select 
exitHandler: 
    Application.EnableEvents = True 
    Exit Sub 
errHandler: 
    MsgBox Err.Number & ": " & Err.Description 
    Goto exitHandler 
     
End Sub 
Private Sub Calendar1_Click() 
    ActiveCell.Value = CDbl(Calendar1.Value) 
    ActiveCell.NumberFormat = "mm/dd/yyyy" 
    ActiveCell.Select 
End Sub 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Application.EnableEvents = True 
    If Target.Cells.Count > 1 Then Exit Sub 
    If Not Intersect(Range("D51:D52"), Target) Is Nothing Then 
        Calendar1.Left = Target.Left + Target.Width - Calendar1.Width 
        Calendar1.Top = Target.Top + Target.Height 
        Calendar1.Visible = True 
         ' select Today's date in the Calendar
        Calendar1.Value = Date 
    ElseIf Calendar1.Visible Then Calendar1.Visible = False 
    End If 
End Sub 


If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines




I need to be able to select multiple entries from a drop down tab that references a named list elsewhere in the workbook. I am able to get the drop down tab to funtion, however it refuses to project those selections into a different cell, or select multiple entries from the list. I have tried several test codes posted on various forums, however when I copy that code over to my spreadsheet, it does not work. I can provide the specific files if need be.
heres the code im currently using on the sheet with the drop down


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler

Dim rngDV As Range
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
If Target.Column = 3 Then
If Target.Value = "" Then GoTo exitHandler
If Target.Offset(0, 1).Value = "" Then
Target.Offset(0, 1).Value = Target.Value
Else
Target.Offset(0, 1).Value = _
Target.Offset(0, 1).Value _
& ", " & Target.Value
End If
End If
End If

exitHandler:
Application.EnableEvents = True

End Sub


How would you search for a value down a column if the column contains a drop down combo box? I certainly hope I have not included too much code to examine - but I did not want to leave anything out so you can see the entire code with other code interaction that is taking place. The combo box and its code in colulmn i is preventing me from searching for values in that column. This code

Code:

Private Sub ComboBox1_Click()
ActiveCell.Offset(0, 1).value = _
WorksheetFunction.Index(Sheets("MYLIST").RANGE("MYRANGE"), _
ComboBox1.ListIndex + 1, 2)

If ActiveCell.value = "DISH TV" Then
        ActiveCell.Offset(0, 2) = Date
        ActiveCell.Offset(0, 3).value = "Autodeb"
        ActiveCell.Offset(0, 4).Select
        DISH.Show
        ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-3).Activate
        SendKeys "{LEFT 1}"

         SendKeys "{LEFT 1}"
End If
End Sub


and this code

Code:

Private Sub Worksheet_SelectionChange(ByVal Target As RANGE)
Dim cboTemp As OLEObject
Set ws = Worksheets("MYLIST")
Set ws = ActiveSheet
Cancel = True
Set cboTemp = ActiveSheet.OLEObjects("ComboBox1")
  On Error Resume Next
If Target.Column = 1 Then
    With cboTemp
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 3
      .ListFillRange = ws.RANGE("MYLIST").Address
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    ComboBox1.DropDown
Else
  With cboTemp
  '.ListFillRange = ""
  '.LinkedCell = ""
  .Visible = False
  End With
End If
End Sub


automatically drops a combobox list down whenever the activecell is in column 1

This code searches for any values in the column "Description" which is where the combo box is, column 1:

Code:

Private Sub CommandButton2_Click()
Dim Comboval, SearchVal, _
    ws As Worksheet, _
    HiddenState As Boolean, _
     Rng As RANGE, RngCell As RANGE, _
    ThisSheet As String, FrstAddrss As String
Comboval = Me.ComboBox1
SearchVal = Me.TextBox1
ThisSheet = ActiveSheet.Name

For Each ws In ThisWorkbook.Worksheets
  
  Select Case ws.Name
    Case "JAN", "FEB", "MAR", "APR", "MAY", "JUN", _
         "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"
      HiddenState = ws.Visible
      ws.Visible = True
      ws.Select
      
      If Comboval = "Description" Then
      Set Rng = RANGE("A1:A100")
      Set RngCell = Rng.Find(What:=SearchVal, After:=[a1], LookIn:=xlFormulas, LookAt:= _
      xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    
      ElseIf Comboval = "Category" Then
      Set Rng = RANGE("B1:B100")
      Set RngCell = Rng.Find(What:=SearchVal, After:=[b1], LookIn:=xlValues, LookAt:= _
      xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    
      'ElseIf Comboval = "Date" Then
      'Set Rng = Range("C1:C100")
      'Set RngCell = Rng.Find(What:=SearchVal, After:=[c1], LookIn:=xlValues, LookAt:= _
      'xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
      
      End If
    
      If Not RngCell Is Nothing Then
      FrstAddrss = RngCell.Address
Do
          RngCell.Select
                   
Dim lRow As Long
Dim wsr As Worksheet
Set wsr = Worksheets("REPORT")
lRow = wsr.Cells(Rows.Count, 1) _
  .End(xlUp).Offset(1, 0).Row
If Trim(SearchVal) = "" Then
Exit Sub
End If

If Comboval = "Description" Then
With wsr
  .Cells(lRow, 1).value = RngCell
  .Cells(lRow, 2).value = RngCell.Cells(1, 2)
  .Cells(lRow, 3).value = RngCell.Cells(1, 3)
  .Cells(lRow, 4).value = RngCell.Cells(1, 4)
  .Cells(lRow, 5).value = RngCell.Cells(1, 5)
  .Cells(lRow, 6).value = RngCell.Cells(1, 6)
End With
End If

Set RngCell = Rng.FindNext(RngCell)
Loop While RngCell.Address  FrstAddrss
End If

ws.Visible = HiddenState
End Select

Next
If RngCell Is Nothing Then MsgBox ("'" & SearchVal & "' is not found on the sheets JAN through DEC."), , SearchVal & " Not Found"
Sheets(ThisSheet).Select
wsr.Activate

End Sub


If I search for "DISH TV" in column 1, the result is nothing - and I have at least 12 values of "DISH TV" in column 1, one for each month on separate sheets of the workbook(12 sheets named JAN...DEC).

Both the combobox on Userform 1 and the combobox in column 1 are named the same, "ComboBox1", but that should not make any difference, should it ?

The problem is, every time column 1 is clicked or moved to, it activates the combo box control. Is there a way in code to disable the combo box action when it is in a column you want to perform another operation on, like searching for values with other code ?

Putting Excel in design mode does not work.

Thanks for all your help

CR


I would like to be able to choose more than one value in a drop down list by holding down the control key. I found a macro that does this by saving the choices in a separate column with the choices separated by commas. My problem is that I have no idea how to put this perfect macro into my spreadsheet.
Can anyone make sense of this and tell me (in really basic terms) how to go about using it? Thanks very much.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
If Target.Count > 1 Then GoTo exitHandler
Application.EnableEvents = False

Dim ws As Worksheet
Dim i As Integer

Set ws = Worksheets("Lists")
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
  'do nothing
Else
    If Target.Value = "" Then GoTo exitHandler
    'add new items to the list
    If Application.WorksheetFunction _
      .CountIf(ws.Range("NameList"), Target.Value) Then
      'do nothing
    Else
      i = ws.Cells(Rows.Count, 3).End(xlUp).Row + 1
      ws.Range("C" & i).Value = Target.Value
      ws.Range("C1").CurrentRegion.Name = "NameList"
      ws.Range("NameList").Sort Key1:=ws.Range("C1"), _
        Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
        
    End If
    If Target.Offset(0, 1).Value = "" Then
      Target.Offset(0, 1).Value = Target.Value
    Else
      Target.Offset(0, 1).Value = _
        Target.Offset(0, 1).Value _
        & Chr(10) & Target.Value
    End If
  End If

exitHandler:
  Application.EnableEvents = True
End Sub





Can some one have a look at this for me please, I cannot seem to get this to work to automatically change text to proper upon data entry,

Something simple I am doing wrong

Code:

#Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then
        Exit Sub
    End If
    On Error GoTo ErrHandler:
    If Not Application.Intersect(Me.Range("A1:A10"), Target) Is Nothing Then
        If IsNumeric(Target.Value) = False Then
            Application.EnableEvents = False
            'Target.Value = StrConv(Target.Text, vbLowerCase)
            'Target.Value = StrConv(Target.Text, vbUpperCase)
            'Target.Value = StrConv(Target.Text, vbProperCase)
            Application.EnableEvents = True
        End If
    End If
ErrHandler:
    Application.EnableEvents = True
End Sub


(The third line is what I am having issues with when the ' is removed nothing)


Hi,
Please can you help me solve 2 problems I am encountering with the following code I have found on the web and am trying to adapt.

When the data validation in K21 changes, the validation lists dependent on K21 in H25, H27, H29 and H31 are supposed to show their first dependent option.* Similarly, when H25, H27, H29 and H31 change as above, the adjacent validation lists dependent on H25, H27, H29 and H31 in K25, K27, K29 and K31 are supposed to show their first dependent options.

The dependent validation lists are changing as expected in 'H' and 'K'. Also, the 'H' dependent lists are refreshing to show the first option of the selected dependent list as expected. However, the 'K' dependent lists are not refreshing to show the first option of the selected dependent lists. In other words, if K21 has 2 options of either Fruit or Vegetables and H25 has dependent lists of fruit and vegetables and K25 has dependent lists of the varieties of fruit and vegetables in H25 then, if I change K21 from Fruit to Vegetables, 'H' will changes to the first option of 'Select Vegetable' but K will still show 'Select Fruit Variety'.

The other problem I am facing is that if I use a combination of INDIRECT and SUBSTITUTE to remove spaces in the dependent list options so that the options equal the list 'Names', the dependent lists work but the VBA completely stops working. I'm guessing I need to introduce something in the code that does the same as my use of SUBSTITUTE in the INDIRECT function to remove spaces?

Thank you for your help.

Code to follow:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errHandler
Dim rng As Range

If Not Intersect(Target, Me.Range("K21")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("H25").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K21")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("H27").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K21")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("H29").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K21")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("H31").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K25")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("K25").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K27")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("K27").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K29")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("K29").Value = rng.Offset(0, 0).Value
End If

If Not Intersect(Target, Me.Range("K31")) Is Nothing Then
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  Set rng = ActiveWorkbook.Names(Target.Value).RefersToRange
  Me.Range("K31").Value = rng.Offset(0, 0).Value
End If

exitHandler:
  Application.EnableEvents = True
  Exit Sub

errHandler:
  MsgBox "Could not change dependent cell"
  GoTo exitHandler
End Sub