Этот код должен дать вам хорошее начало.Исправить и настроить в соответствии с вашими потребностями.Внимательно изучите настройки разделов кода.WSChange
должно работать идеально, за исключением того, что, может быть, есть что-то странное в этих открытых переменных (вы всегда можете поместить их в процедуру ... и события ... Я не получаю их, но я скоро это сделаю.
Нельзя использовать диапазон из другого листа, чтобы использовать его в качестве диапазона проверки (аналогично условному форматированию, то есть для Excel 2003), поэтому необходимо указать имя для использования в качестве диапазона.
Этот элемент входит в модуль . Я просто не смог увидеть его на листе:
Option Explicit
Public strMain As String
Public Const cStrValList As String = "ValList" 'Validation List Name
Sub WSChange()
'-- Customize BEGIN --------------------
'Name of the main worksheet containing the validation RANGE.
'*** The worksheet should be defined by name so that this script can be run ***
'*** from other worksheets (Do NOT use the Activesheet, if not necessary). *** ***
Const cStrMain As String = "Main" 'If "" then Activesheet is used.
'Name of the worksheet containing the validation LIST.
Const cStrSys As String = "System 1"
'*** The next two constants should be defined as first cell ranges, so when ***
'*** adding new data, the last cell could be calculated again and the data *** ***
'*** wouldn't be 'out of bounds' (outside the range(s)).
'Validation RANGE Address. Can be range or first cell range address.
Const cStrMainRng As String = "$M$2" 'orig. "$M$2"
'Validation LIST Range Address. Can be range or first cell range address.
Const cStrSysRng As String = "$A$1" 'orig. "$A$1:$BB$1"
'-- Customize END ----------------------
strMain = cStrMain
Dim oWsMain As Worksheet
Dim oRngMain As Range
Dim oWsSys As Worksheet
Dim oRngSys As Range
Dim oName As Name
Dim strMainRng As String
Dim strMainLast As String
Dim strSysRng As String
Dim strSysLast As String
'---------------------------------------
On Error GoTo ErrorHandler 'No error handling so far!
'---------------------------------------
'Main Worksheet
If cStrMain <> "" Then 'When cStrMain is used as the worksheet name.
Set oWsMain = ThisWorkbook.Worksheets(cStrMain)
Else 'cStrMain = "", When ActiveSheet is used instead. Not recommended.
Set oWsMain = ThisWorkbook.ActiveSheet
End If
With oWsMain
If .Range(cStrMainRng).Cells.Count <> 1 Then
strMainRng = cStrMainRng
Else
'Calculate Validation Range Last Cell Address
strMainLast = .Range(Cells(Rows.Count, _
.Range(cStrMainRng).Column).Address).End(xlUp).Address
'Calculate Validation Range and assign to a range variable
strMainRng = cStrMainRng & ":" & strMainLast 'First:Last
End If
Set oRngMain = .Range(strMainRng) 'Validation Range
End With
'---------------------------------------
'System Worksheet
Set oWsSys = Worksheets(cStrSys) 'Worksheet with Validation List
With oWsSys
If .Range(cStrSysRng).Cells.Count <> 1 Then
strSysRng = cStrSysRng
Else
'Calculate Validation Range Last Cell Address
strSysLast = .Range(Cells(.Range(cStrSysRng).Row, _
Columns.Count).Address).End(xlToLeft).Address
'Calculate Validation Range and assign to a range variable
strSysRng = cStrSysRng & ":" & strSysLast 'First:Last
End If
Set oRngSys = .Range(strSysRng) 'Validation List Range
End With
'---------------------------------------
'Name
For Each oName In ThisWorkbook.Names
If oName.Name = cStrValList Then
oName.Delete
Exit For 'If found, Immediately leave the For Each Next loop.
End If
Next
ThisWorkbook.Names.Add Name:=cStrValList, RefersTo:="='" & cStrSys _
& "'!" & strSysRng
With oRngMain.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & cStrValList
End With
'---------------------------------------
ProcedureExit:
Set oRngMain = Nothing
Set oRngSys = Nothing
Set oWsSys = Nothing
Set oWsMain = Nothing
Exit Sub
'---------------------------------------
ErrorHandler:
'Handle Errors!
MsgBox "An error has occurred.", vbInformation
GoTo ProcedureExit
'---------------------------------------
End Sub
И некоторые ' события ', не такхорошо, но у меня кончилось терпение.
Это на самом деле входит в рабочую таблицу ' Система 1 '. Возможно, вам следует найти что-то подобное для основного листа.
Option Explicit
Public PreviousTarget As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
'MsgBox Target.Cells.Count
'-- Customize BEGIN --------------------
Const cStr1 = "Validation List Change"
Const cStr2 = "Values have changed"
Const cStr3 = "Previous Value"
Const cStr4 = "Current Value"
'-- Customize END ----------------------
Dim str1 As String
'Values in the NAMED RANGE (cStrValList)
'Only if a cell in the named range has been 'addressed' i.e. a cell is
'selected and you start typing or you click in the fomula bar, and then
'enter is pressed, this will run which still doesn't mean the value has
'been changed i.e. the same value has been written again... If the escape
'key is used it doesn't run.
If Not Intersect(Target, Range(cStrValList)) Is Nothing Then
If Target.Cells.Count > 1 Then
WSChange
MsgBox "Cannot handle multiple cells, yet."
Else
'Check if the value has changed.
If PreviousTarget <> Target.Value Then 'The value has changed.
WSChange
str1 = cStr1 & vbCrLf & vbCrLf & cStr2 & ":" & vbCrLf & vbCrLf & "'" & _
Target.Address & "' " & cStr3 & " = '"
str1 = str1 & PreviousTarget & "'" & vbCrLf & "'" & Target.Address
str1 = str1 & "' " & cStr4 & " = '" & Target.Value & "'."
MsgBox str1, vbInformation
Else 'The value has not changed.
End If
End If
Else 'The cell range is out of bounds.
End If
'Values in the NAMED RANGE ROW outside the NAMED RANGE (cStrValList9
Dim strOutside As String
'Here comes some bad coding.
strOutside = Range(cStrValList).Address
strOutside = Split(strOutside, ":")(1)
strOutside = Range(strOutside).Offset(0, 1).Address
strOutside = strOutside & ":" _
& Cells(Range(strOutside).Row, Columns.Count).Address
If Not Intersect(Target, Range(strOutside)) Is Nothing Then
If Target.Cells.Count > 1 Then
WSChange
MsgBox "Cannot handle multiple cells, yet."
Else
If PreviousTarget <> Target.Value Then 'The value has changed.
If strMain <> "" Then
WSChange
Else
MsgBox "You have to define a worksheet by name under 'cStrMain'."
End If
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This gets the 'previous' Target value. This is gold concerning the speed of
'execution. It's a MUST REMEMBER.
PreviousTarget = Target.Value
End Sub
Sub vallister()
MsgBox Range(cStrValList).Address
End Sub
Sub sdaf()
End Sub