İki ve daha fazla renkli olan satırlar silinsin

[tahsinanarat]

Ekli dosyada gönderdiğim örnek dosyamda, a sutunundaki satırlarda birinci renkli kelimeler haricindeki satırların silinmesini istiyorum, yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[tahsinanarat]

Örnek dosyada hücrede bulunan renkli kelimeleri saydırabilirsek de benim işim görülür.

 

[halit3]

Örnek dosyada hücrede bulunan renkli kelimeleri saydırabilirsek de benim işim görülür.

nakta,virgül,farantes ile başlıyanları ayırt etmiyor diğerlerini ayırt ediyor

Sub ayır()
For i = 1 To [a65536].End(3).Row
Worksheets(ActiveSheet.Name).Cells(i, 1).Select
deg1 = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
j = 1
For j = 1 To Len(Worksheets(ActiveSheet.Name).Cells(i, 1).Value) + 1
On Error Resume Next
If ActiveCell.Characters(Start:=1, Length:=j).Font.FontStyle = "Kalın" Then
Worksheets(ActiveSheet.Name).Cells(i, 2).Value = ActiveCell.Characters(Start:=1, Length:=j).Text
ActiveCell.Characters(Start:=1, Length:=j).Font.ColorIndex = 3
End If
Next j
deg2 = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Trim(Mid(deg1, Len(deg2) + 1, Len(deg1)))
Next i
MsgBox "işlem tamam"
End Sub

 

[halit3]

sabahleyin dinç kafayla birazcık uğraştım buldum galiba

Sub ayır()
For i = 1 To [a65536].End(3).Row
deg1 = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
For j = 1 To Len(Worksheets(ActiveSheet.Name).Cells(i, 1).Value) + 1
On Error Resume Next
If Worksheets(ActiveSheet.Name).Cells(i, 1).Characters(Start:=j, Length:=1).Font.ColorIndex = 5 Then
Worksheets(ActiveSheet.Name).Cells(i, 2).Value = Worksheets(ActiveSheet.Name).Cells(i, 1).Characters(Start:=1, Length:=j).Text
'Worksheets(ActiveSheet.Name).Cells(i, 1).Characters(Start:=j, Length:=1).Font.ColorIndex = 3 ' burası doğrulama renk olarak değişiyor
End If
Next j
deg2 = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Trim(Mid(deg1, Len(deg2) + 1, Len(deg1)))
Next i
MsgBox "işlem tamam"
End Sub

 

[tahsinanarat]

Sn. halit3 hocam renkli kelimeler ile renksizlerin ayrılması mükemmel olmuş elinize bilginize sağlık, birde bir kelimeden fazla renkli satırları sildirebilirmiyiz, yada renki kelimelerin kaç adet olduğunu B sutununa da yazdırabilirsek bu da benim işimi görecektir. 1. mesajdaki örnek dosya halen geçerlidir. Saygılarımla.

 

[halit3]

Sn. halit3 hocam renkli kelimeler ile renksizlerin ayrılması mükemmel olmuş elinize bilginize sağlık, birde bir kelimeden fazla renkli satırları sildirebilirmiyiz, yada renki kelimelerin kaç adet olduğunu B sutununa da yazdırabilirsek bu da benim işimi görecektir. 1. mesajdaki örnek dosya halen geçerlidir. Saygılarımla.

sorunu anlıyamadım zaten son mesajdaki kod renklileri ve renksizlerin ayırımını yapıyor b ve c sütunlarına bunun dışında başka bir şey varsa örnek dosya ile belirleyiniz. bir bakalım.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Kontrol etmeniz için sildirme işlemini yaptırmadım. Kod içinde başında tek tırnak bulunan satırı aktif hale getirirseniz ilgili satırlar silinir. Lütfen kontrol ettikten sonra ilgili satırı aktif hale getirin.

Option Explicit
 
Sub RENGE_GÖRE_SİL()
    Dim X As Long, Y As Integer
    
    Application.ScreenUpdating = False
    
    For X = Range("A65536").End(3).Row To 1 Step -1
        For Y = 1 To Len(Cells(X, 1))
            If Cells(X, 1).Characters(Start:=Y, Length:=1).Font.ColorIndex = 5 Then
                Cells(X, 2).Value = Cells(X, 1).Characters(Start:=1, Length:=Y).Text
            End If
            
            If InStr(1, Cells(X, 2), " ") > 0 Then Cells(X, 3) = "SİL"
            
            'If InStr(1, Cells(X, 2), " ") > 0 Then Rows(X).Delete
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[tahsinanarat]

Sn. Korhan hocam elinize sağlık tam istediğim gibi olmuş, elinize sağlık, ayrıca Halit hocamın kodları da ayırma konusunda işime yarayacak her ikinize de ayrı ayrı teşekkür ederim. Sağolasınız.

 

[tahsinanarat]

Sn. Korhan hocam, 40000 satırda çok yavaş çalışıyor, aynı komutun daha hızlı olmasi için başka herhangi birşey yapılabilir mi?

 

[Korhan Ayhan]

Selamlar,

Döngü ile tüm satırlara ait verilerin karakterlerine renk kontrolü yapıldığı için işlem uzun sürmektedir.

Üstteki mesajımdaki koda küçük bir ekleme yaptım. Ekran hareketlerini pasifize ettim. Belki size biraz hız kazandırabilir.

Bunun yanında eğer kontrol edilecek karakter sayısını kendimiz belirlersek kodu biraz daha hızlandırma şansımız var. Aksi halde bu süreye katlanmak zorundasınız.

Aşağıdaki kod satırını sayısal bir değerle değiştirip kodu denerseniz biraz daha hız kazanabilirsiniz.

Len(Cells(X, 1))

 

[tahsinanarat]

Sn. Korhan hücam, ilginize çok teşekkür ediyorum. Sağolasınız.