Excel cari ekstre makrosu yardımı

[ismailg]

AŞAĞIDAKİ MAKROYU 5000 İNCİ SATIRA KADAR YAPMAK İSTİYORUM

6 NO.LU SATIRDAN BAŞLAYIP 5000 İNCİ SATIRA KADAR AYNI İŞLEMİ YAPICAK. AMAÇ SOL TARAFTAKİ BENİM FATURA NUMARAMDAN ARAMA YAPIP DİĞER SUTUNDA BU FATURA NOSUNU BULUP RENKLENDİRMESİ, YOK İSE ARATTIĞIMI FARKLI BİR RENK YAPMASI. DAHA BASİT BİR YOLU VARSA YARDIM RİCA EDİYORUM..





Sub Makro8()
'
' Makro8 Makro
' Makro ece tarafından 15.10.2011 tarihinde kaydedildi.
'

'
Cells.Find(What:="TARİH", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B6").Select
ActiveCell.FormulaR1C1 = "999"
Cells.Find(What:="999", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Selection.Interior.ColorIndex = 3
Range("F6").Select
Selection.Interior.ColorIndex = 3
Range("H6").Select
Selection.Interior.ColorIndex = 3
Range("I6").Select
Selection.Interior.ColorIndex = 3
Cells.FindNext(After:=ActiveCell).Activate
Selection.Interior.ColorIndex = 3
Range("C6").Select
Selection.Interior.ColorIndex = 3
Range("D6").Select
Selection.Interior.ColorIndex = 3
Range("A6").Select
Selection.Interior.ColorIndex = 3
Cells.Find(What:="TARİH", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B7").Select
ActiveCell.FormulaR1C1 = "888"
Cells.Find(What:="888", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Selection.Interior.ColorIndex = 3
Range("F7").Select
Selection.Interior.ColorIndex = 3
Range("H7").Select
Selection.Interior.ColorIndex = 3
Range("I7").Select
Selection.Interior.ColorIndex = 3
Cells.FindNext(After:=ActiveCell).Activate
Selection.Interior.ColorIndex = 3
Range("A7").Select
Selection.Interior.ColorIndex = 3
Range("C7").Select
Selection.Interior.ColorIndex = 3
Range("D7").Select
Selection.Interior.ColorIndex = 3
Cells.Find(What:="TARİH", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B8").Select
ActiveCell.FormulaR1C1 = "777"
Cells.Find(What:="777", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate
Range("B8").Select
Selection.Interior.ColorIndex = 1
Range("B8").Select
Selection.Font.ColorIndex = 3
Range("A8").Select
End Sub

 

[halit3]

Olmayanlar için gerek yok zaten hücre rengi beyaz olarak belli oluyor.

kod:

Sub faturabul()
Cells.Interior.ColorIndex = xlNone
For i = 6 To Cells(Rows.Count, "B").End(3).Row
aranan = Cells(i, "b").Value
With Range("G:G")
Set c = .Find(aranan, .Cells(.Cells.Count), xlValues, xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Cells(c.Row, "a").Interior.ColorIndex = 3
Cells(c.Row, "b").Interior.ColorIndex = 3
Cells(c.Row, "c").Interior.ColorIndex = 3
Cells(c.Row, "d").Interior.ColorIndex = 3
Cells(c.Row, "f").Interior.ColorIndex = 3
Cells(c.Row, "g").Interior.ColorIndex = 3
Cells(c.Row, "h").Interior.ColorIndex = 3
Cells(c.Row, "ı").Interior.ColorIndex = 3

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
End Sub