Makro Kodunun Alanını Değiştirmede Yardım

[baydeniro]

Merhaba arkadaşlar. aşağıdaki makro kodu sadece A kolonu için değişiyor. Farklı varyantları denedim ama beceremedim. Alanı B : C arası nasıl yapabilirim.

Sub Kırmızıbul()
For X = 1 To [A65536].End(3).Row
For Y = 1 To Len(Cells(X, 1))
If Cells(X, 1).Characters(Start:=Y, Length:=Y).Font.ColorIndex = 3 Then
Cells(X, 2).Value = "Kırmızı"
End If
Next
Next
End Sub

 

[kulomer46]

Yukarıdaki kodunuz A sütunundaki değerlere bakıp B sütununa yazıyor.

Aşağıdaki ilk kod B sütunundaki değerlere bakıp C sütununa yazıyor
Sub Kırmızıbul()
For X = 1 To [B65536].End(3).Row
For Y = 1 To Len(Cells(X, 2))
If Cells(X, 2).Characters(Start:=Y, Length:=1).Font.ColorIndex = 3 Then
Cells(X, 3).Value = "Kırmızı"
End If
Next
Next
End Sub

Aşağıdaki kod ise C sütunundaki değerlere bakıp D sütununa yazıyor
Sub Kırmızıbul()
For X = 1 To [C65536].End(3).Row
For Y = 1 To Len(Cells(X, 3))
If Cells(X, 3).Characters(Start:=Y, Length:=1).Font.ColorIndex = 3 Then
Cells(X, 4).Value = "Kırmızı"
End If
Next
Next
End Sub

Aşağıdada kırmızı renkli olan karakterlerin kaçıncı sırada olduğu yazılıyor..
Sub Kırmızıbul()
Dim bul
For X = 1 To [A65536].End(3).Row
For Y = 1 To Len(Cells(X, 1))
If Cells(X, 1).Characters(Start:=Y, Length:=1).Font.ColorIndex = 3 Then
bul = bul & Y & ". "
End If
Next
If bul <> "" Then Cells(X, 2).Value = bul & " Karakter K&#305;rm&#305;z&#305; renktedir."
bul = ""
Next
End Sub

 

[baydeniro]

Sayın kulomer46 ilginize çok çok teşekkür ederim.

Alanı şu şekilde nasıl düzenleyebiliriz : A sütununaz bakıp B sütunlarına kopyalasın.

 

[kulomer46]

Neyi kopyalas&#305;n? T&#252;m de&#287;erlerimi, sadece k&#305;rm&#305;z&#305; olan karakterleri mi? Daha a&#231;&#305;k anlat&#305;rsan&#305;z yard&#305;mc&#305; olal&#305;m..

 

[baydeniro]

Sayın kulomer46 sadece kırmızı font olanlar kopyalacak.

 

[kulomer46]

Sub K&#305;rm&#305;z&#305;bul()
Dim bul
For X = 1 To [A65536].End(3).Row
For y = 1 To Len(Cells(X, 1))
If Cells(X, 1).Characters(Start:=y, Length:=1).Font.ColorIndex = 3 Then
bul = bul & Mid(Cells(X, 1).Value, y, 1)
End If
Next
If bul <> "" Then Cells(X, 2).Value = bul
bul = ""
Next
End Sub

&#304;yi &#231;al&#305;&#351;malar

 

[baydeniro]

Teşekkürler.

Sayın kulomer46 ilginize çok çok teşekkür ederim.