Modifying a Code...

[Anthony G.]

Hello to All...

I have two workbooks that utilize the same code with the slightest of variations. The following code is embedded in Book1 in a worksheet labeled 'Rdg' - the proceeding code in Book2 is in a worksheet labeled 'Sci'

I've tried to combine the two in the same workbook by placing the code in two different modules but have been unsuccessful. Listed below is the Module Code, which is relatively the same between the two workbooks with the exception of a few r.offset modifications. I though that by independently pointing the worksheet codes to their respective module codes would do the trick - but I can't figure it out.

Any help, as always, will be greatly appreciated - Thanks - Anthony

Rdg: Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
With Worksheets("Rdg")
Set r = Union(Range("i6:j300"), Range("i301:j400"))
End With
If Not Intersect(Target, r) Is Nothing Then
SetCellValidation Target
End If
End Sub

Sci:Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
With Worksheets("Sci")
Set r = Union(Range("E10"), Range("E11"))
End With
If Not Intersect(Target, r) Is Nothing Then
SetCellValidation Target
End If
End Sub

Sub SetCellValidation(r As Range)
Dim list As String
list = GetValidationRangeName(r.Value)
If Len(list) > 0 Then
CreateValidation r.Offset(1, 0), list
r.Offset(1, 0).ClearContents
r.Offset(1, 0).Select
Else
r.Offset(1, 0).Validation.Delete
End If
End Sub

Function GetValidationList(dist As String) As String
Dim list As String
Set r = Worksheets("Sheet1").Range("B2")
While r.Value <> "" And r.Value <= dist
If r.Value = dist Then
If Len(list) > 0 Then
list = list & ","
End If
list = list & r.Offset(0, 1)
End If
Set r = r.Offset(1, 0)
Wend

GetValidationList = list
End Function

Function GetValidationRangeName(dist As String) As String
Dim list As String
Dim rngName As String
Dim begr As Range, endr As Range
Dim x As Range

rngName = Replace(dist, " ", "")
rngName = Replace(rngName, "-", "")
' On Error Resume Next
' If Range(rngName) Is Nothing Then
' On Error GoTo 0

Set r = Worksheets("Sheet1").Range("B2")
While r.Value <> "" And r.Value <= dist
If r.Value = dist Then
If begr Is Nothing Then
Set begr = r
End If
End If
Set r = r.Offset(1, 0)
Wend
If begr Is Nothing Then
GetValidationRangeName = ""
GoTo EndFunction
End If
If (r.Offset(-1, 0).Address = begr.Address) Then
Set endr = begr
Else
Set endr = r.Offset(-1, 0)
End If
Set x = Range(begr, endr).Offset(0, 1)
ActiveWorkbook.Names.Add Name:=rngName, RefersTo:="=Sheet1!" & x.Address
' End If
GetValidationRangeName = "=" & rngName
EndFunction:
End Function[/b]

 

[bat17]

You don't say what is happening! What is not working?
The Worksheet_Change events should be in there own worksheet code pages rather than in seperate modules.

Peter

 

[Anthony G.]

The Original Workbook, with the worksheet 'Rdg', had code in a module and the The Worksheet_Change Event is in it's worksheet. Now, I'd like to add a second worksheet to the workbook, 'Sci', and have it carry out the same functions as outlined in the original code but with two exceptions - have the 'Sci' Worksheet_Range change from I6:J300 to E10:E11 - which would then require the r.offset(1,0) to be changed (in some sections of the code) to r.offset(0,1). As a result of this, I copied the code in Module1, placed it in Module2, changed some of the r.offset's and attempted to have the Worksheet code in 'Sci' point in that direction...but I can't get it to work.

My apologies for not explaining this further on the first go-around.

Looking forward to some suggestions.

Thanks...Anthony

 

[Anthony G.]

Any luck on this one? In my current workbook the code in Module1 is running 5 worksheets that have their own Worksheet Code. All I'm looking to do is to copy the code in Module1 and place it into a new Module and Modify the offsets to shift the placements of the ranges (drop-down menus).

Is this possible?

Thanks...Anthony