aktarılan veriyı renklendırme

[osmanucel]

Sub Düğme6_Tıklat()
Dim i As Long, _
Sat As Long, _
Adet As Long, _
s1 As Worksheet, _
s2 As Worksheet, _
Hesap As String, _
BasTar As Date, _
BitTar As Date

Set s1 = Sheets("VERİLER")
Rows("4:" & Rows.Count).Clear

Set s2 = Sheets("FTABLO")

s2.Select
BasTar = Range("B1")
BitTar = Range("B2")
Hesap = Range("B3")


Sat = Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False

For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row

If s1.Cells(i, "C") >= BasTar And s1.Cells(i, "C") <= BitTar And s1.Cells(i, "E") = Hesap Then
Sat = Sat + 1
Adet = Adet + 1
s1.Range("A" & i & ":I" & i).Copy Cells(Sat, "A")

End If
Next i
Application.ScreenUpdating = True
If Adet = 0 Then
MsgBox "Koşula Göre Aktarılacak Bilgi Bulamadım...."
Else
MsgBox Adet & " Adet Koşula Uyan Kayıt Aktarılmıştır..."
End If
End Sub



bu kodlar işimi göruyo
verılerdekı bılgılerden aktardıklarım
kırmızı yazı olabılırmı acaba yardımcı olabılırmısınız

 

[asi_kral]

Sub Düğme6_Tıklat()
Dim i As Long, _
Sat As Long, _
Adet As Long, _
s1 As Worksheet, _
s2 As Worksheet, _
Hesap As String, _
BasTar As Date, _
BitTar As Date

Set s1 = Sheets("VERİLER")
Rows("4:" & Rows.Count).Clear

Set s2 = Sheets("FTABLO")

s2.Select
BasTar = Range("B1")
BitTar = Range("B2")
Hesap = Range("B3")


Sat = Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False

For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row

If s1.Cells(i, "C") >= BasTar And s1.Cells(i, "C") <= BitTar And s1.Cells(i, "E") = Hesap Then
Sat = Sat + 1
Adet = Adet + 1
s1.Range("A" & i & ":I" & i).Copy Cells(Sat, "A")

End If
Next i
Application.ScreenUpdating = True
If Adet = 0 Then
MsgBox "Koşula Göre Aktarılacak Bilgi Bulamadım...."
Else
MsgBox Adet & " Adet Koşula Uyan Kayıt Aktarılmıştır..."
End If
End Sub



bu kodlar işimi göruyo
verılerdekı bılgılerden aktardıklarım
kırmızı yazı olabılırmı acaba yardımcı olabılırmısınız

Merhaba

Sub Düğme6_Tıklat()
Dim i As Long, _
Sat As Long, _
Adet As Long, _
s1 As Worksheet, _
s2 As Worksheet, _
Hesap As String, _
BasTar As Date, _
BitTar As Date

Set s1 = Sheets("VERİLER")
Rows("4:" & Rows.Count).Clear

Set s2 = Sheets("FTABLO")

s2.Select
BasTar = Range("B1")
BitTar = Range("B2")
Hesap = Range("B3")


Sat = Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False

For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row

If s1.Cells(i, "C") >= BasTar And s1.Cells(i, "C") <= BitTar And s1.Cells(i, "E") = Hesap Then
Sat = Sat + 1
Adet = Adet + 1
s1.Range("A" & i & ":I" & i).Copy Cells(Sat, "A")
[COLOR="Red"]s1.Range("A" & i & ":I" & i).Font.Color = vbRed[/COLOR]
End If
Next i
Application.ScreenUpdating = True
If Adet = 0 Then
MsgBox "Koşula Göre Aktarılacak Bilgi Bulamadım...."
Else
MsgBox Adet & " Adet Koşula Uyan Kayıt Aktarılmıştır..."
End If
End Sub

Şeklinde dener misiniz_?

 

[osmanucel]

cok tesekkur ederım sagolun
sadece yazı kırmızıya dönermı acaba

 

[asi_kral]

cok tesekkur ederım sagolun
sadece yazı kırmızıya dönermı acaba

Üstteki kodu güncelledim.

 

[osmanucel]

Cok teşekkur ederım

 

[asi_kral]

Cok teşekkur ederım

Kolay Gelsin.