Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2004 Pazar

Interior Descriptions


'Module1

Sub KırmızıSatırıSil()
On Error Resume Next
Dim Hücre As Range, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Hücre = Intersect(Range("A:A"), ActiveSheet.UsedRange)
For i = Hücre.Count To 1 Step -1
If Hücre.Item(i).Interior.ColorIndex = 3 Then
Hücre.Item(i).EntireRow.Delete
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub BoşDoluHücreleriRenklendir()
On Error Resume Next
Dim Hücre As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each Hücre In Intersect(Selection, ActiveCell.EntireColumn, ActiveSheet.UsedRange)
Select Case Hücre.Value
Case (Is >= 50)
Hücre.EntireRow.Interior.ColorIndex = 20
Case (Is >= 40)
Hücre.EntireRow.Interior.ColorIndex = 37
Case (Is >= 20)
Hücre.EntireRow.Interior.ColorIndex = 38
Case (Is >= 0)
Hücre.EntireRow.Interior.ColorIndex = 36
Case Else
Hücre.EntireRow.Interior.ColorIndex = 44
End Select
Next Hücre
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub 

'Sheets("Sayfa1") Module

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, Range("A1:B10")) Is Nothing Then Exit Sub
If (Target.Value > 10) Then
Target.Interior.ColorIndex = 6
Else
Target.Interior.ColorIndex = xlNone
End If
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul