Metin Silme

[hb3102]

Merhaba ekteki dosyada D sütununda yer alan kırmızı ile işaretli alanların otomatik silmek istiyorum.Teşekkürler

 

[askm]

Sub askm()
Dim Son As Long
Application.ScreenUpdating = False
Son = Range("C" & Rows.Count).End(3).Row
For i = 2 To Son
    Say = InStr(1, Cells(i, 4), "Ch")
    Cells(i, 6) = Mid(Cells(i, 4), Say + 3, Len(Cells(i, 4).Value)) 'Veriyi F sütununa aldırmak için Cells(i,6) yaptım. Aynı hücrede olsun derseniz Cells(i,4) yazın)
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[hb3102]

Askm çok teşekkürler

 

[askm]

Rica ederim. Kolay gelsin.

 

[çıtır]

Alternatif olarak:Sayfanın kodu olarak kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
If Intersect(Target, [D2:D5000]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Sat = Cells(65336, "D").End(3).Row
For i = 2 To Sat
Say = InStr(1, Cells(i, 4), ", Ch:")
If Say = 0 Then GoTo 10
Son = Len(Range("D" & i)) - Len(WorksheetFunction.Substitute(Range("D" & i), ":", ""))
If Son = 0 Then GoTo 10
al = Split(Range("D" & i), ":")
Cells(i, 4) = al(2)
10:
Next i
Application.ScreenUpdating = True
End Sub