Cell color change when value is found in Range

M

madhur

New Member
Joined
Apr 7, 2011
Messages
2
I have a annual meeting calender. In this calender different meetings are booked in different colors. (eg. sales, marketing, HR, Finance)
For every department meeting is booked in every month.

To view only one meeting at a time on click a have this formula.

This formula works fine but it takes to much time to search in all months because of while-wend. Is there any way I can speed up the process on Click?

Help please!!!!!

Sub SM()

Dim LRow As Integer
Dim Lcell As String
Dim Lce As String
Dim LColorCells As String
Dim lac As String

Lce = "S"
LRow = 4
lac = "S66"
Lcell = Lce & LRow

While Lcell <> lac

While LRow < 66

Lcell = Lce & LRow

LColorCells = Lcell

Select Case Left(Range(Lcell).Value, 4)


Case "SM"
Range(LColorCells).Interior.ColorIndex = 4
Range(LColorCells).Interior.Pattern = xlSolid

Case Else
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = xlNone

End Select
LRow = LRow + 1



Wend

If LColorCells = "S65" Then
LRow = 4
Lce = "T"
lac = "T66"
End If
If LColorCells = "T65" Then
LRow = 4
Lce = "W"
lac = "W66"
End If
If LColorCells = "W65" Then
LRow = 4
Lce = "X"
lac = "X66"
End If
If LColorCells = "X65" Then
LRow = 4
Lce = "AA"
lac = "AA66"
End If

If LColorCells = "AA65" Then
LRow = 4
Lce = "AB"
lac = "AB66"
End If
If LColorCells = "AB65" Then
LRow = 4
Lce = "AE"
lac = "AE66"
End If
If LColorCells = "AE65" Then
LRow = 4
Lce = "AF"
lac = "AF66"
End If
If LColorCells = "AF65" Then
LRow = 4
Lce = "AI"
lac = "AI66"
End If
If LColorCells = "AI65" Then
LRow = 4
Lce = "AJ"
lac = "AJ66"
End If
If LColorCells = "AJ65" Then
LRow = 4
Lce = "AM"
lac = "AM66"
End If
If LColorCells = "AM65" Then
LRow = 4
Lce = "AN"
lac = "AN66"
End If
If LColorCells = "AN65" Then
LRow = 4
Lce = "AQ"
lac = "AQ66"
End If
If LColorCells = "AQ65" Then
LRow = 4
Lce = "AR"
lac = "AR66"
End If
If LColorCells = "AR65" Then
LRow = 4
Lce = "AU"
lac = "AU66"
End If
If LColorCells = "AU65" Then
LRow = 4
Lce = "AV"
lac = "AV66"
End If
If LColorCells = "AV65" Then
LRow = 4
Lce = "AY"
lac = "AY66"
End If
If LColorCells = "AY65" Then
LRow = 4
Lce = "AZ"
lac = "AZ66"
End If
If LColorCells = "AZ65" Then
LRow = 4
Lce = "BC"
lac = "BC66"
End If
If LColorCells = "BC65" Then
LRow = 4
Lce = "BD"
lac = "BD66"
End If
If LColorCells = "BD65" Then
LRow = 4
Lce = "BG"
lac = "BG66"
End If
If LColorCells = "BG65" Then
LRow = 4
Lce = "BH"
lac = "BH66"
End If
If LColorCells = "BH65" Then
LRow = 4
Lce = "BK"
lac = "BK66"
End If
If LColorCells = "BK65" Then
LRow = 4
Lce = "BL"
lac = "BL65"


End If

Wend

Range("A1").Select

End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
I have a annual meeting calender. In this calender different meetings are booked in different colors. (eg. sales, marketing, HR, Finance)
For every department meeting is booked in every month.

To view only one meeting at a time on click a have this formula.

This formula works fine but it takes to much time to search in all months because of while-wend. Is there any way I can speed up the process on Click?

Help please!!!!!

Sub SM()

Dim LRow As Integer
Dim Lcell As String
Dim Lce As String
Dim LColorCells As String
Dim lac As String

Lce = "S"
LRow = 4
lac = "S66"
Lcell = Lce & LRow

While Lcell <> lac

While LRow < 66

Lcell = Lce & LRow

LColorCells = Lcell

Select Case Left(Range(Lcell).Value, 4)


Case "SM"
Range(LColorCells).Interior.ColorIndex = 4
Range(LColorCells).Interior.Pattern = xlSolid

Case Else
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = xlNone

End Select
LRow = LRow + 1



Wend

If LColorCells = "S65" Then
LRow = 4
Lce = "T"
lac = "T66"
End If
If LColorCells = "T65" Then
LRow = 4
Lce = "W"
lac = "W66"
End If
If LColorCells = "W65" Then
LRow = 4
Lce = "X"
lac = "X66"
End If
If LColorCells = "X65" Then
LRow = 4
Lce = "AA"
lac = "AA66"
End If

If LColorCells = "AA65" Then
LRow = 4
Lce = "AB"
lac = "AB66"
End If
If LColorCells = "AB65" Then
LRow = 4
Lce = "AE"
lac = "AE66"
End If
If LColorCells = "AE65" Then
LRow = 4
Lce = "AF"
lac = "AF66"
End If
If LColorCells = "AF65" Then
LRow = 4
Lce = "AI"
lac = "AI66"
End If
If LColorCells = "AI65" Then
LRow = 4
Lce = "AJ"
lac = "AJ66"
End If
If LColorCells = "AJ65" Then
LRow = 4
Lce = "AM"
lac = "AM66"
End If
If LColorCells = "AM65" Then
LRow = 4
Lce = "AN"
lac = "AN66"
End If
If LColorCells = "AN65" Then
LRow = 4
Lce = "AQ"
lac = "AQ66"
End If
If LColorCells = "AQ65" Then
LRow = 4
Lce = "AR"
lac = "AR66"
End If
If LColorCells = "AR65" Then
LRow = 4
Lce = "AU"
lac = "AU66"
End If
If LColorCells = "AU65" Then
LRow = 4
Lce = "AV"
lac = "AV66"
End If
If LColorCells = "AV65" Then
LRow = 4
Lce = "AY"
lac = "AY66"
End If
If LColorCells = "AY65" Then
LRow = 4
Lce = "AZ"
lac = "AZ66"
End If
If LColorCells = "AZ65" Then
LRow = 4
Lce = "BC"
lac = "BC66"
End If
If LColorCells = "BC65" Then
LRow = 4
Lce = "BD"
lac = "BD66"
End If
If LColorCells = "BD65" Then
LRow = 4
Lce = "BG"
lac = "BG66"
End If
If LColorCells = "BG65" Then
LRow = 4
Lce = "BH"
lac = "BH66"
End If
If LColorCells = "BH65" Then
LRow = 4
Lce = "BK"
lac = "BK66"
End If
If LColorCells = "BK65" Then
LRow = 4
Lce = "BL"
lac = "BL65"


End If

Wend

Range("A1").Select

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Trigger email and retrieve data from other cells when a cell color changes.
Replies
0
Views
522
Sha
S
L
  • Question Question
Copy daily changing rows from a workbook paste to another workbook
Replies
1
Views
625
OaklandJim
O
X
  • Solved
Problems when i add new rows in table via userform. Formulas wont get taken over and cell formats are changing
Replies
7
Views
576
Anthony47
A
Q
  • Question Question
Change row color based on other cell values within a specific range
Replies
1
Views
538
Q_cripple
Q
J
  • Question Question
keeping range address in tact after changing range cell value
Replies
3
Views
364
Z51
Z

Forum statistics

Threads
1,224,505
Messages
6,179,152
Members
452,891
Latest member
JUSTOUTOFMYREACH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top