I'm trying to match any part of a text string of keywords to text in the Target cell.
If it is a text value, of a single keyword, like "wal" for Wal-mart, then this code finds the text string in the Target, i.e. " WAL-MART SUPERCENTER ".
When I have "wal otherstore" in the keywords cell it doesn't find Wal-mart anymore. I thought that is what xlPart was supposed to do.
Set Found = Target.Find(What:=Cell, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
The idea is to have a list of accounts in a budget spreadsheet with associated keywords, so that the macro then finds keywords, like "wal" and assigns the Target entry to that account.
The keywords are all in a single cell next to the accounts list. The keywords are separated by a space.
Full code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Cell As Range, Found As Range
Dim List As String
Dim Qty As Integer
Dim Coll As Collection
Dim i As Long
LastRowA = Sheets("Transactions").Cells(Rows.Count, "A").End(xlUp).Row
LastRowL = Sheets("Transactions").Cells(Rows.Count, "L").End(xlUp).Row
List = "Reset Options"
Qty = 0
Set Coll = New Collection
Set Rng1 = Sheets("Transactions").Range("G3:G" & LastRowA)
Set Rng2 = Sheets("Accounts & Budget").Range("I5:I104")
Set Rng3 = Sheets("Transactions").Range("L3:L" & LastRowL)
If Application.Intersect(Target, Rng1) Is Nothing Then
ElseIf Application.Intersect(Target, Rng1).Address = Target.Address Then
If Target = "" Then
Application.EnableEvents = False
Target.Offset(0, 5).Validation.Delete
Cells(Target.Row, "G") = ""
Cells(Target.Row, "L") = ""
Application.EnableEvents = True
ElseIf Target <> "" Then
For Each Cell In Rng2
Set Found = Target.Find(What:=Cell, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Found Is Nothing Then
Else
Qty = Qty + 1
Coll.Add Cell.Offset(0, -2)
End If
Next Cell
If Qty = 1 And Coll.Count = 1 Then
Application.EnableEvents = False
Target.Offset(0, 5).Validation.Delete
Target.Offset(0, 5) = Coll(1)
Target.Offset(0, 5).Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=Accounts"
Application.EnableEvents = True
ElseIf Qty = 0 And Coll.Count = 0 Then
Application.EnableEvents = False
Target.Offset(0, 5).Validation.Delete
Target.Offset(0, 5) = "No Results - Select From List"
Target.Offset(0, 5).Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=Accounts"
Application.EnableEvents = True
ElseIf Qty > 1 And Coll.Count > 1 Then
Application.EnableEvents = False
Target.Offset(0, 5).Validation.Delete
Target.Offset(0, 5) = "Multiple Results - Select From List"
For i = 1 To Coll.Count
List = List & "," & Coll(i)
Next i
Target.Offset(0, 5).Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=List
Application.EnableEvents = True
End If
End If
End If
If Application.Intersect(Target, Rng3) Is Nothing Then
ElseIf Application.Intersect(Target, Rng3).Address = Target.Address Then
If Target = "Reset Options" Or Target = "" Then
Application.EnableEvents = False
Target.Validation.Delete
Target.Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=Accounts"
Application.EnableEvents = True
Target = "Select From List"
ElseIf Target.Offset(0, -5) = "" Then
Application.EnableEvents = False
Target.Validation.Delete
Target = ""
Application.EnableEvents = True
End If
End If
Application.ScreenUpdating = True
End Sub
Related
I'm trying to update hyperlinks in one Excel spreadsheet, using a Find in another sheet in the same workbook.
The problem occurs on j = c.Find(k).Row, where I receive the message
"Runtime error '91:' Object variable or With block variable not set."
It doesn't give me any issues with the d = c.Find(m).Row which looks like it's been set up identically.
I know nothing about error handling in VBA - I've just never had to use it - so maybe there's something wrong with the result of the search?
Sub HypFix()
Dim k As String
Dim m As String
Dim i As Long
Dim g As String
Dim d As String
Dim j As String
Dim c As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'CHANGE SHEET NAMES BELOW AS NEEDED
Set c = Sheets("Tables").Range("A1:A15071")
For i = 4 To 337
If Sheets("Contents").Cells(i, "A").Value <> "" Then
k = Sheets("Contents").Cells(i, "A").Value
m = Right(Sheets("Contents").Cells(i, "A").Value, 255)
g = Sheets("Contents").Cells(i, "A").Value
If Len(Sheets("Contents").Cells(i, "A").Value) > 255 Then
d = c.Find(m).Row
Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Cells(i, "A"), _
Address:="", _
SubAddress:="'Tables'!A" & d, _
TextToDisplay:=g
ElseIf Len(Sheets("Contents").Cells(i, "A").Value) <= 255 Then
j = c.Find(k).Row
Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Cells(i, "A"), _
Address:="", _
SubAddress:="'Tables'!A" & j, _
TextToDisplay:=g
End If
End If
Next i
'Message Box when tasks are completed
MsgBox "Task Complete!"
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.CalculateFull
End Sub
You should always set a range to the Range.Find(). This allows you to test whether a value was found without throwing an error.
Sub HypFix()
Dim i As Long
Dim c As Range
Dim Target As Range
Dim What As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'CHANGE SHEET NAMES BELOW AS NEEDED
Set c = Sheets("Tables").Range("A1:A15071")
With Sheets("Contents")
For i = 4 To 337
What = .Cells(i, "A").Value
If Len(What) > 0 Then
Set Target = c.Find(What:=What, LookIn:=xlValues)
Rem Test if anything was found
If Not Target Is Nothing Then
Rem Look for the Last 255 characters
Set Target = c.Find(What:=Right(What, 255), LookIn:=xlValues)
End If
Rem If something was found link it
If Not Target Is Nothing Then
.Hyperlinks.Add Anchor:=.Cells(i, "A"), Address:="", SubAddress:="'Tables'!A" & Target.Row
Else
Rem Leave yourself a message of what wasn't found
Debug.Print What, " in row "; i; "Not Found"
End If
End If
Next i
End With
'Message Box when tasks are completed
MsgBox "Task Complete!"
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.CalculateFull
End Sub
Note: When the TextToDisplay parameter is omitted from .Hyperlinks.Add the Anchor cell's test is displayed.
The Fruits contains list - Apple,Banana,Orange
and
Colors contains list - Red,Black,Orange
so when I multi select the Fruits as well as Colors from drop-down list from cell "G1". Then the "Offset(0, -1)" means "F1" shows me the combine output list as - (Apple, Banana, Orange, Red, Black, Orange).
So, The list in cell "F1" contains duplicate value Orange and it prints 2 times.
It should pick up only unique items from the selected one and remove the duplicate one and should print in cell F1 as - (Apple, Banana, Orange, Red, Black).
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range, oldVal As String, newVal As String
Dim arr As Variant, El As Variant
If Target.count > 1 Then GoTo exitHandler
If Target.value = "" Then
Application.EnableEvents = False
Target.Offset(0, -1).value = ""
Application.EnableEvents = True
Exit Sub
End If
On Error Resume Next
Set rngDV = cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Not Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
newVal = Target.value: Application.Undo
oldVal = Target.value: Target.value = newVal
If Target.Column = 7 Then
If oldVal <> "" Then
If newVal <> "" Then
arr = Split(oldVal, ",")
For Each El In arr
If El = newVal Then
Target.value = oldVal
GoTo exitHandler
End If
Next
Target.value = oldVal & "," & newVal
Target.EntireColumn.AutoFit
End If
End If
End If
writeSeparatedStringLast Target
End If
exitHandler:
Application.EnableEvents = True
End Sub
Sub writeSeparatedStringLast(rng As Range)
Dim arr As Variant, arrFin As Variant, El As Variant, k As Long, listBox As MSForms.listBox
Dim arrFr As Variant, arrVeg As Variant, arrAnim As Variant, El1 As Variant
Dim strFin As String ', rng2 as range
arrFr = Split("Apple,Banana,Orange", ",")
arrVeg = Split("Onion,Tomato,Cucumber", ",")
arrAnim = Split("Red,Black,Orange", ",")
arr = Split(rng.value, ",")
For Each El In arr
Select Case El
Case "Fruits"
arrFin = arrFr
Case "Vegetables"
arrFin = arrVeg
Case "Colors"
arrFin = arrAnim
End Select
For Each El1 In arrFin
strFin = strFin & El1 & ", "
Next
Next
strFin = left(strFin, Len(strFin) - 1)
With rng.Offset(0, -1)
.value = strFin
.WrapText = True
.Select
End With
End Sub
'Firstly run the next Sub, in order to create a list validation in range "G1":
Sub CreateValidationBis()
Dim sh As Worksheet, rng As Range
Set sh = ActiveSheet
Set rng = sh.Range("G1")
With rng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="Fruits,Vegetables,Colors"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End Sub
Is this code will fit to remove the duplicates from output arrays and give me the unique value.
Public Function RemoveDuplicateWords(InputString As String) As String
Dim InputArray() As String
InputArray = Split(InputString, " ")
Dim DictUnique As Object
Set DictUnique = CreateObject("Scripting.Dictionary")
Dim OutputString As String
Dim Word As Variant
For Each Word In InputArray
If Not DictUnique.Exists(Word) Then
DictUnique.Add Word, 1
OutputString = OutputString & " " & Word
End If
Next Word
RemoveDuplicateWords = Trim$(OutputString)
End Function
In The following worksheet macro, I am attempting to perform different actions, depending on the column selected. In 2 cases the action performed depends on the Column selected and the column value.
For example, if a name is entered in column A, the date is automatically entered in column B.
When a drop down value is entered in Column L, date is entered in Column M. If data in column L = "Fees Received" or "Policy No. Issued" data is copied to another worksheet and the date is entered in column m.
All individual components are working. However not all the time.
I need the macro to identify the column and perform the correct action such that I can move from column to column and the macro to constantly run in the background and working correctly for all selected columns.
Private Sub Worksheet_Change(ByVal Target As Range)
'Dim C As Range, V
Dim answer As Integer
Dim LRowCompleted As Integer
Application.EnableEvents = False
MsgBox "Target Column is " & Target.Column
MsgBox "Target Value is " & Target.Value
If Target.Column = 1 Then
GoTo AddEntryDate
End If
If Target.Column = 12 Then
GoTo AddWorkStatusDate
End If
If (Target.Column = 12 And Target.Value = "Fees Received") Then
GoTo FeesReceived
End If
If (Target.Column = 12 And Target.Value = "Policy No. Issued") Then
GoTo PolicyNoIssued
End If
Exit Sub
AddEntryDate:
'Update on 11/11/2019 -If data changes in column L Activity , insert
'today's date into column M - Date of Activity
Dim WorkRng As Range
Dim rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("A:A"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each rng In WorkRng
If Not VBA.IsEmpty(rng.Value) Then
rng.Offset(0, xOffsetColumn).Value = Now
rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
rng.Offset(3, xOffsetColumn).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
Exit Sub
AddWorkStatusDate:
'Update on 11/11/2019 -If data changes in column L Activity , insert
'today's date into column M - Date of Activity
Dim WorkRng2 As Range
Dim rng2 As Range
Dim yOffsetColumn As Integer
Set WorkRng2 = Intersect(Application.ActiveSheet.Range("L:L"), Target)
yOffsetColumn = 1
If Not WorkRng2 Is Nothing Then
Application.EnableEvents = False
For Each rng2 In WorkRng2
If Not VBA.IsEmpty(rng2.Value) Then
rng2.Offset(0, yOffsetColumn).Value = Now
rng2.Offset(0, yOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
rng2.Offset(0, yOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
Exit Sub
PolicyNoIssued:
Sheets("Income").Select
LRowCompleted = Sheets("Income").Cells(Rows.Count, "A").End(xlUp).Row '
'Request confirmation from the user, in form of yes or no
answer = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If answer = vbYes Then
Range("A" & Target.Row & ":A" & Target.Row).Copy
Sheets("Income").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.EnableEvents = True
Else
MsgBox "This client will not be copied to the Income Worksheet"
Application.EnableEvents = True
End If
Exit Sub
FeesReceived:
'Define last row on Income worksheet to know where to place the row of data
Sheets("Income").Select
LRowCompleted = Sheets("Income").Cells(Rows.Count, "A").End(xlUp).Row
'Request confirmation from the user, in form of yes or no
answer = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If answer = vbYes Then
Range("A" & Target.Row & ":A" & Target.Row).Copy
Sheets("Income").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.EnableEvents = True
Else
MsgBox "This client will not be copied to the Income Worksheet"
Application.EnableEvents = True
End If
Application.EnableEvents = True
End Sub
From what I can see, you need to monitor only 2 columns. Rest of your requirements is just subsets of those requirements.
Your code can be re-written as below (UNTESTED) Let me know if you get any error? Also since you are working with Worksheet_Change, you may want to see THIS.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim lRow As Long
Dim ans As Variant
On Error GoTo Whoa
Application.EnableEvents = False
'~~> Check if the change happened in Col A
If Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.Count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I have a Worksheet_change in which two events are checked (edits on cells of column C and edits on cells of column D). The problem is that an edit on column C's cells modify the value of column D's cells (and viceversa), so the Worksheet_change is triggered repeatedly and excel eventually crashes.
How can I avoid the problem but maintaining my functionality?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
Set targ = Intersect(Target, Range("A:A"))
If Not targ Is Nothing Then
With Worksheets("FT_CASE_xx")
For Each defVal In .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
Dim xlFirstChar As String
xlFirstChar = Left$(currParam, 1)
If xlFirstChar = "B" Then
Set rgFound = Worksheets("DEF_BOOLEAN").Range("A:A").Find(currParam.value)
defVal.Offset(, 1).Interior.Color = RGB(230, 230, 230)
defVal.Offset(, 1).Locked = True
defVal.Offset(, 2).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="TRUE,FALSE"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Else
Set rgFound = Worksheets("DEF_FLOAT").Range("A:A").Find(currParam.value)
defVal.Offset(, 1).Interior.ColorIndex = 0
defVal.Offset(, 1).Locked = False
defVal.Offset(, 2).Locked = False
defVal.Offset(, 1).NumberFormat = "0.000"
defVal.Offset(, 2).NumberFormat = "0.000"
defVal.Offset(, 3).NumberFormat = "0.000"
End If
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
If xlFirstChar = "B" Then
Set currParamDict = rgFound.Offset(, 3)
Else
Set currParamDict = rgFound.Offset(, 5)
End If
defVal.value = currParamDict.value
End If
Next defVal
End With
Else
Set targ = Intersect(Target, Range("C:C"))
If Not targ Is Nothing Then
Dim coeffVal As Range
Dim currVal As Range
Dim RequestedVal As Range
With Worksheets("FT_CASE_xx")
For Each coeffVal In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
Set currVal = coeffVal.Offset(, -1)
Set RequestedVal = coeffVal.Offset(, 1)
Set ParamName = coeffVal.Offset(, -2)
Dim xlFirstChar2 As String
xlFirstChar2 = Left$(ParamName, 1)
If ((xlFirstChar2 = "F") And (IsEmpty(coeffVal.value) = False)) Then
RequestedVal.value = coeffVal.value * currVal.value
End If
Next coeffVal
End With
Else
Set targ = Intersect(Target, Range("D:D"))
If Not targ Is Nothing Then
Dim coeffsVal As Range
Dim val As Range
Dim reqVal As Range
Dim Parameter As Range
With Worksheets("FT_CASE_xx")
For Each reqVal In .Range("D2", .Range("D" & Rows.Count).End(xlUp))
Set coeffsVal = reqVal.Offset(, -1)
Set val = reqVal.Offset(, -2)
Set Parameter = reqVal.Offset(, -3)
Dim xlFirstChar3 As String
xlFirstChar3 = Left$(Parameter, 1)
If ((xlFirstChar3 = "F") And (IsEmpty(reqVal.value) = False)) Then
If val.value = 0 Then
coeffsVal.value = reqVal.value
Else
coeffsVal.value = reqVal.value / val.value
End If
End If
Next reqVal
End With
Else
Exit Sub
End If
End If
End If
End Sub
Maybe a different management of target intersection? How?
My favoured method (which can also be useful in other situations) is to create a variable at global or module level (as required) then check this on each run of the code
Private disableEvents as Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If disableEvents Then Exit Sub
disableEvents=True
<code here>
disableEvents=False
End sub
I have an Excel workbook which contains multiple sheets. I want to hide/unhide sheets based on cell values in Main sheet cells B3:B8. Values in Main sheet are changed by the user from pre-defined list.
Eg. If "A" exists in the "Config" column, then unhide sheet "A" in my workbook.
At the moment I have following code, which works, but looks
clunky, Excel flickers as the code runs every time a value is changed in "Config" column:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = False
Sheets("B").Visible = False
Sheets("C").Visible = False
Sheets("D").Visible = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then
Sheets("A").Visible = True
ElseIf InStr(1, Cells(i, 2), "B") Then
Sheets("B").Visible = True
ElseIf InStr(1, Cells(i, 2), "C") Then
Sheets("C").Visible = True
ElseIf InStr(1, Cells(i, 2), "D") Then
Sheets("D").Visible = True
End If
Next i
End Sub
I also tried to run this macro from a button, but it stops with first TRUE value (a sheet becomes unhidden).
I would use this method:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = xlSheetHidden
Sheets("B").Visible = xlSheetHidden
Sheets("C").Visible = xlSheetHidden
Sheets("D").Visible = xlSheetHidden
Application.ScreenUpdating = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then Sheets("A").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "B") Then Sheets("B").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "C") Then Sheets("C").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "D") Then Sheets("D").Visible = xlSheetVisible
Next i
Application.ScreenUpdating = True
End Sub
Another way to do this would be:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RNG As Range, CL As Range
Dim WS As Worksheet
Application.ScreenUpdating = False
Set RNG = Sheets("Main").Range("B3:B8")
If Not Intersect(Target, RNG) Is Nothing Then
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "Main" Then
With RNG
Set CL = .Find(What:=WS.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not CL Is Nothing Then
WS.Visible = xlSheetVisible
Else
WS.Visible = xlSheetHidden
End If
End With
End If
Next WS
End If
Application.ScreenUpdating = True
End Sub
More versatile and more dynamic
EDIT: To also check if Target intersects with your lookup range to prevent triggering macro unwanted.
To help optimize the running and have it look better use Application.ScreenUpdating. It will reduce the flickering by not trying to repaint the scrren until the Sub has finished running. If the rest of the program runs with no issue it should be all you need
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = False
Sheets("B").Visible = False
Sheets("C").Visible = False
Sheets("D").Visible = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then
Application.ScreenUpdating = False
Sheets("A").Visible = True
ElseIf InStr(1, Cells(i, 2), "B") Then
Application.ScreenUpdating = False
Sheets("B").Visible = True
ElseIf InStr(1, Cells(i, 2), "C") Then
Application.ScreenUpdating = False
Sheets("C").Visible = True
Application.ScreenUpdating = False
ElseIf InStr(1, Cells(i, 2), "D") Then
Sheets("D").Visible = True
End If
Next i
Application.sScreenUpdating = True
End Sub
I also agree with 's comment. Ifs would be better. ElseIf assumes only one condition is the correct one when there could be multiple iterations.
edit:
Also a though: It looks like the way its set up you intend that any value between B3:B8 that has an "A" will show page "A". If you dedicate it differently B3 = "A" , B4="B" etc and so on, you can change the conditionals to If Target.Address = "$B$3" Then and have B# be the on/off to sheet"A" with any non-empty value.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$B$3" Then
If IsEmpty(Sheet1.Range("B3")) = False Then
Sheets("A").Visible = True
Else
Sheets("A").Visible = False
End If
End If
''etc etc and so on
Application.ScreenUpdating = True
End Sub