Alternatif kod.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row < 2 Then Exit Sub
If Target.Column <> 11 Then Exit Sub
If Target.Rows.Count <> 1 Then Exit Sub
If Mid(Target.Value, InStrRev(Target.Value, " ") + 1) = "" Then
Cells(Target.Row, "M").Value = ""
Else
Cells(Target.Row, "M").Value = Mid(Target.Value, InStrRev(Target.Value, " ") + 1)
End If
End Sub
@
feraz hocam yukardaki kod birden fazla hücre ekleyip sildiğimizde çalışmıyor galiba?
bu arada kendi kodumda da düzeltme yaptım ilk satırda değişiklik olmaması için satır kontrolünü ekledim
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K:K")) Is Nothing Then 'sadece K sütununa bakar
Dim cll As Range
AdrX = Target.Address
If InStr(AdrX, ":") > 0 Then ilk = Split(AdrX, "$")(2): Son = Split(AdrX, "$")(4) Else ilk = Split(AdrX, "$")(2) & ":": Son = Split(AdrX, "$")(2)
Set Trgt = Range("K" & ilk & "K" & Son)
For Each cll In Trgt
If cll.Row > 1 Then 'satır kontrolü
Set Rng = cll
AdresIlIlce (Rng)
End If
Next cll
End If
End Sub
yada
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K:K")) Is Nothing Then 'sadece K sütununa bakar
Dim cll As Range
AdrX = Target.Address
If InStr(AdrX, ":") > 0 Then ilk = Split(AdrX, "$")(2): Son = Split(AdrX, "$")(4) Else ilk = Split(AdrX, "$")(2) & ":": Son = Split(AdrX, "$")(2)
If ilk = "1:" Then ilk = "2:"
If Son < 2 Then Son = 2
Set Trgt = Range("K" & ilk & "K" & Son)
For Each cll In Trgt
Set Rng = cll
AdresIlIlce (Rng)
Next cll
End If
End Sub
(15/08/2021, 09:59)berduş yazdı: [ -> ]@feraz hocam yukardaki kod birden fazla hücre ekleyip sildiğimizde çalışmıyor galiba?
Target.Rows.Count <> 1 Then Exit Sub
Yukardaki kodu eklemiştim abey çoklu veri girince hata vermesin diye.
Birden bzla silme yada kopyalayıp yapıştırmada bir döngü kurulur mesela
for i = Selection.row to Selection.rows.count -1
Sonra burda işlem kodları eklenir.
Ben instrew kodu göstermiştim bu aramaya sondan başlıyor.instr nin tersi yani.
InStrRev(Target.Value, " ")
Berduş hocam o kadar kod yazmadan yukardaki basitçe buluyor örnek
Gfgjgddaaghhdag burda a bulunacaksa sonuç 14 verir abey
Private Sub Worksheet_Change(ByVal Target As Range)
Dim parca As String, i As Long, kacinci As Integer
If Target.Row < 2 Then Exit Sub
If Target.Column <> 11 Then Exit Sub
If Target.Rows.Count = 1 Then
kacinci = InStrRev(Target.Value, " ")
If kacinci > 0 Then
parca = Mid(Target.Value, kacinci + 1)
Cells(Target.Row, "M").Value = IIf(parca = "", "", parca)
Else
Cells(Target.Row, "M").Value = ""
End If
ElseIf Target.Rows.Count > 1 Then
For i = Selection.Row To (Selection.Cells.Count - 1) + Selection.Row
kacinci = InStrRev(Cells(i, Target.Column).Value, " ")
If kacinci > 0 Then
parca = Mid(Cells(i, Target.Column).Value, kacinci + 1)
Cells(i, "M").Value = IIf(parca = "", "", parca)
Else
Cells(i, "M").Value = ""
End If
Next
End If
End Sub
Buda hızlı veriyon
Private Sub Worksheet_Change(ByVal Target As Range)
Dim parca As String, i As Long, kacinci As Integer
Dim arr, say As Long, secilenRow As Long
Const AktarmaSutun As String = "M"
If Target.Row < 2 Then Exit Sub
If Target.Column <> 11 Then Exit Sub
If Target.Rows.Count = 1 Then
kacinci = InStrRev(Target.Value, " ")
secilenRow = Target.Row
If kacinci > 0 Then
parca = Mid(Target.Value, kacinci + 1)
Cells(Target.Row, AktarmaSutun).Value = IIf(parca = "", "", parca)
Else
Cells(Target.Row, AktarmaSutun).Value = ""
End If
ElseIf Target.Rows.Count > 1 Then
secilenRow = Selection.Row
ReDim arr(1 To (Selection.Cells.Count - 1) + Selection.Row, 1 To 1)
For i = Selection.Row To (Selection.Cells.Count - 1) + Selection.Row
kacinci = InStrRev(Cells(i, Target.Column).Value, " ")
If kacinci > 0 Then
say = say + 1
parca = Mid(Cells(i, Target.Column).Value, kacinci + 1)
arr(say, 1) = IIf(parca = "", "", parca)
Else
say = say + 1: arr(say, 1) = ""
End If
Next
End If
If say > 0 Then Cells(secilenRow, AktarmaSutun).Resize(say, 1).Value = arr
On Error Resume Next
Erase arr
End Sub