Hasan, why have 2000 cells withdatavalidationin sheet 1 and have thelistin sheet 3, surely it would be better just to have thelistin
sheet 1 too?
Regards,
Simon Lloyd
'Microsoft Office Help' (
http://www.thecodecage.com)
I am trying to create an automated procedure, where in the User
1. Exports thedatainto an excel file(Say Sheet3)
2. Selects thevaluein Sheet1.Column A (which isdatavalidationlist
from sheet3.Column A)
3. Dependinguponthe criteria in below code it updates thedatain
relavent sheet else gives error.
4. I need to further automize the things, like Dependingupontheselectionfrom thevalidationlistin Sheet1 I want the other columns
(B,D,F,G) in Sheet1 topopulateits corresponding
values in Sheet3.Column C,F,G,M
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Dim wsLoop As Worksheet
Dim FoundCell As Range
Dim myAddr As String
Dim TopRng As Range
Dim BotRng As Range
Dim BigRng As Range
Dim LastRow As Long
Dim FirstRow As Long
Dim res As Variant
myAddr = "A2:A2000"
With Sh.Range(myAddr)
FirstRow = .Row
LastRow = .Rows(.Rows.Count).Row
End With
If Intersect(Target, Sh.Range(myAddr)) Is Nothing Then
Exit Sub
End If
If Target.Cells.Count > 1 Then
Exit Sub 'singlecellat a time
End If
If Target.Value= "" Then
'do nothing
Else
For Each wsLoop In ThisWorkbook.Worksheets
Select Case LCase(wsLoop.Name)
Case Is = LCase("Sheet3")
'skip it
Case Else
Set BigRng = wsLoop.Range(myAddr)
If LCase(wsLoop.Name) = LCase(Sh.Name) Then
With BigRng
If Target.Row = FirstRow Then
'in row 2, don't include it
Set BigRng = .Resize(.Rows.Count -
1).Offset(1, 0)
Else
If Target.Row =LastRow Then
'in row 200, don't include it
Set BigRng = .Resize(.Rows.Count - 1)
Else
Set TopRng = wsLoop.Range("A" &
FirstRow _
& ":A" & Target.Row -
1)
Set BotRng = wsLoop.Range("A" &
Target.Row + 1 _
& ":A" & LastRow)
Set BigRng = Union(TopRng, BotRng)
End If
End If
End With
End If
With BigRng
Set FoundCell = .Cells.Find(what:=Target.Value, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows,
_
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If FoundCell Is Nothing Then
'not found
Else
MsgBox "That entry already exists here:" & vbLf _
& FoundCell.Address(external:=True)
Application.EnableEvents = False
Target.ClearContents
Application.Goto FoundCell, Scroll:=True 'or
false??
Application.EnableEvents = True
Exit For
End If
End Select
Next wsLoop
res _
= Application.VLookup(Target.Value, Worksheets("Sheet3").Range
("A:R"), 18, False)
If IsError(res) Then
'no message
Else
If LCase(Sh.Name) = LCase(res) Then
'do nothing
Else
MsgBox Target.Value& " should be on " & res
Application.EnableEvents = False
Target.Value= ""
Application.EnableEvents = True
End If
End If
End If
End Sub
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx- Hide quoted text -
- Show quoted text -