Veri al makrosuna ilave ricası

[drummers]

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
s2.Range("c2:c200").Value = s1.Range("b2:b200").Value

End Sub

Üstteki makromda "data" sekmesindeki "b2:b200" aralığındaki verilerimi "kontrol" sekmeme aktarmaktayım.

İsteğim şudur: "data" sekmesindeki "b2:b200" aralığında bazı verilerimin renkleri "KIRMIZI" bu makroma eğer "b2:b200" aralığında kırmızı ile yazılmış veri varsa aktarma şartını ekliyebilirmiyiz.

Örnek dosya eklemeye gerek duymadım. Teşekkürler

 

[leumruk]

Merhaba,
Aşağıdaki gibi deneyin.

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
Application.FindFormat.Font.ColorIndex = 3
Set Bul = s1.Range("b2:b200").Find(What:="*", After:=s1.[b2], LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
If Bul Is Nothing Then
s2.Range("c2:c200").Value = s1.Range("b2:b200").Value
End If
Application.FindFormat.Clear
End Sub

 

[drummers]

Merhaba,
Aşağıdaki gibi deneyin.

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
Application.FindFormat.Font.ColorIndex = 3
Set Bul = s1.Range("b2:b200").Find(What:="*", After:=s1.[b2], LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True)
If Bul Is Nothing Then
s2.Range("c2:c200").Value = s1.Range("b2:b200").Value
End If
Application.FindFormat.Clear
End Sub

Compile error:
Variable not defined

bu hatayı alıyorum

 

[leumruk]

Compile error:
Variable not defined
bu hatayı alıyorum

Kodu denedim, ben de herhangi bir hata vermediği gibi, istediğiniz işlemi de gerçekleştirdi. Bir yerlerde hata yapmış olabilir misiniz?
Ya da örnek bir dosya hazırlayıp ekler misiniz? Üzerinde inceleyeyim.

 

[drummers]

dosya eklenmiştir.

 

[leumruk]

Set Bul tanımında hata veriyor. Sebebini araştırma imkanım olmadı. Kodu aşağıdaki gibi kullanın.

NOT: Hücrelerinizdeki metnin koşullu biçimlendirme olduğu eklediğiniz dosyayı incelerken sürpriz olarak karşıma çıktı. Dolayısıyla hazırladığım kod yalnızca normal biçimlendirmelerde çalışacaktır, bilginiz olsun. Koşullu biçimlendirmede çalışacak bir yöntem geliştirebilirsem eklerim.

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
Application.FindFormat.Font.ColorIndex = 3
If s1.Range("b2:b200").Find(What:="*", After:=s1.[b2], LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True) Is Nothing Then
s2.Range("c2:c200").Value = s1.Range("b2:b200").Value
End If
Application.FindFormat.Clear
End Sub

 

[leumruk]

Merhaba,
Koşullu biçimlendirme için aşağıdaki gibi bir kod geliştirdim. Döngü ile de halletmek mümkün; ama bu daha hızlı olacaktır.

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
Dim knt As Boolean
kbcm = s1.Range("b2:b200").FormatConditions.Count
If kbcm = -1 Or kbcm > 0 Then
For Each rnk In s1.Range("b2:b200").SpecialCells(xlCellTypeAllFormatConditions)
If rnk.FormatConditions(1).Font.ColorIndex = 3 Then
knt = True
Exit For
End If
Next
End If
If knt = True Then
s2.Range("c2:c200").Value = s1.Range("b2:b200").Value
End If
End Sub

 

[halit3]

Alternatif kod

Sub Kontrol_Listesi_Aktar()
Dim s1 As Worksheet, s2 As Worksheet
Dim i, sat
Set s1 = Sheets("data")
Set s2 = Sheets("kontrol")
sat = 1
For i = 2 To 200
If s1.Cells(i, "b").Font.ColorIndex <> 3 Then
sat = sat + 1
s2.Cells(sat, "c").Value = s1.Cells(i, "b").Value
End If
Next
End Sub

 

[yorum.halil]

Yanlış yere yazmışım...