A:K Sütunları arası Koşullu biçimlendirme

[sdegirmenci]

Merhaba;
Ekteki dosyam üzerinde açıkladığım gibi Forumda bularak eklediğim ve yalnızca "b" sütununda koşullu biçimlendirme yapan kodun "B:K" sütunları arasında çalışmasını istiyorum, Bu konuda dosyamı açarak bakabilirseniz sevinirim. Şimdiden teşekkür ediyorum.

 

[halit3]

Rapor sayfasının kod bölümündeki bütün kodları siliniz ve aşağıdaki kodu ekleyip deneyiniz,

Private Sub ComboBox1_Change()
Range("B5:K200").Interior.ColorIndex = xlNone
Set RP = Sheets("Rapor")
Set İL = Sheets(ComboBox1.Value)
If ComboBox1 <> "" Then
Application.ScreenUpdating = False
[B5:J200].ClearContents
Satır = 5
Set Bul = İL.[E:E].Find((ComboBox1))
If Not Bul Is Nothing Then
ADRES = Bul.Address
Do
If İL.Cells(Bul.Row, "E") = [DD1] Then
Cells(Satır, "C") = Satır - 4             'SIRA NO
'Cells(Satır, "O") = İL.Cells(Bul.Row, "B") 'TARİH
Cells(Satır, "G") = İL.Cells(Bul.Row, "C") 'SIRA NO
Cells(Satır, "B") = İL.Cells(Bul.Row, "G") 'GRUP NO
Cells(Satır, "C") = İL.Cells(Bul.Row, "E") 'İLİ
Cells(Satır, "D") = İL.Cells(Bul.Row, "F") 'İLÇESİ
Cells(Satır, "E") = İL.Cells(Bul.Row, "D") 'KÖY ADI
Cells(Satır, "F") = İL.Cells(Bul.Row, "H") 'SEKTÖRÜ
Cells(Satır, "H") = İL.Cells(Bul.Row, "I") 'ÖDENEK
Cells(Satır, "I") = İL.Cells(Bul.Row, "N") 'ÖDENEK TOPLAMI
Cells(Satır, "J") = İL.Cells(Bul.Row, "O") 'HARCAMA
Satır = Satır + 1
End If
Set Bul = İL.[E:E].FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> ADRES
[C15].Select
End If
End If
Set Bul = Nothing
Set RP = Nothing
Set İL = Nothing
Application.ScreenUpdating = False
Range("K5").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("K5").Select
Selection.AutoFill Destination:=Range("K5:K200"), Type:=xlFillDefault
Range("K5:K200").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Range("A1").Select
Rows("5:200").EntireRow.Hidden = False
For x = 5 To 200
If Cells(x, 8).Value = "" Then
Rows(x).Hidden = True
Else
For i = 2 To 11
If x Mod 2 = 1 Then
Cells(x, i).Interior.ColorIndex = 6
Else
Cells(x, i).Interior.ColorIndex = 8
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub

 

[halit3]

yada bunu deneyiniz.

Private Sub ComboBox1_Change()
Range("B5:K200").Interior.ColorIndex = xlNone
Set RP = Sheets("Rapor")
Set İL = Sheets(ComboBox1.Value)
If ComboBox1 <> "" Then
Application.ScreenUpdating = False
[B5:J200].ClearContents
Satır = 5
Set Bul = İL.[E:E].Find((ComboBox1))
If Not Bul Is Nothing Then
ADRES = Bul.Address
Do
If İL.Cells(Bul.Row, "E") = [DD1] Then
Cells(Satır, "C") = Satır - 4 'SIRA NO
'Cells(Satır, "O") = İL.Cells(Bul.Row, "B") 'TARİH
Cells(Satır, "G") = İL.Cells(Bul.Row, "C") 'SIRA NO
Cells(Satır, "B") = İL.Cells(Bul.Row, "G") 'GRUP NO
Cells(Satır, "C") = İL.Cells(Bul.Row, "E") 'İLİ
Cells(Satır, "D") = İL.Cells(Bul.Row, "F") 'İLÇESİ
Cells(Satır, "E") = İL.Cells(Bul.Row, "D") 'KÖY ADI
Cells(Satır, "F") = İL.Cells(Bul.Row, "H") 'SEKTÖRÜ
Cells(Satır, "H") = İL.Cells(Bul.Row, "I") 'ÖDENEK
Cells(Satır, "I") = İL.Cells(Bul.Row, "N") 'ÖDENEK TOPLAMI
Cells(Satır, "J") = İL.Cells(Bul.Row, "O") 'HARCAMA
For i = 2 To 11
Cells(Satır, i).Interior.ColorIndex = İL.Cells(Bul.Row, "G").Interior.ColorIndex
Next
Cells(Satır, "k") = "=RC[-2]-RC[-1]"
Satır = Satır + 1
End If
Set Bul = İL.[E:E].FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> ADRES
[C15].Select
End If
End If
Set Bul = Nothing
Set RP = Nothing
Set İL = Nothing
Application.ScreenUpdating = False
Range("A1").Select
Rows("5:200").EntireRow.Hidden = False
For x = 5 To 200
If Cells(x, 8).Value = "" Then
Rows(x).Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub

 

[sdegirmenci]

Merhaba;
Çok değerli halit3 hocam; Önce göstermiş olduğunuz ilgiye çok teşekkür ederim, Kodları uyguladım, tam istediğim gibi oldu.Bütün işleriniz hep kolay gelsin. Saygılarımla

 

[halit3]

Merhaba;
Çok değerli halit3 hocam; Önce göstermiş olduğunuz ilgiye çok teşekkür ederim, Kodları uyguladım, tam istediğim gibi oldu.Bütün işleriniz hep kolay gelsin. Saygılarımla

iyi çalışmalar