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

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
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
Trigger email and retrieve data from other cells when a cell color changes.
Replies
0
Views
353
Sha
S
L
  • Question
Copy daily changing rows from a workbook paste to another workbook
Replies
1
Views
466
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
333
Anthony47
A
Q
  • Question
Change row color based on other cell values within a specific range
Replies
1
Views
420
Q_cripple
Q
J
  • Question
keeping range address in tact after changing range cell value
Replies
3
Views
270
Z51
Z

Forum statistics

Threads
1,214,383
Messages
6,119,196
Members
448,874
Latest member
Lancelots

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