Dolu Satır ekleme

[Harun_Y]

Merhaba değerli üstatlarım;
Bir sorum olacaktı
Eğer satır belirli bir metin içeriyorsa alt satır satır doluysa yeni satır ekleyip başka bir metin ekleme
yapılabilir mi?

Örneğin
Ankara
İstanbul
yazıyorsa Ankara satırının altına 06 satırını ekleme

teşekkürler

 

[Trilenium]

Dim ara As String
Dim yaz As String
sonsatir = Range("A65536").End(xlUp).Row


ara = InputBox("Aranacak Deger", "Aranacak Degeri Yaz")

For i = 2 To sonsatir

If Range("A" & i).Value = ara Then

Range("A" & i + 1).EntireRow.Insert
Range("A" & i + 1).Select
yaz = InputBox("Yazilacak Deger", "Yazilacak Degeri Yaz")
Range("A" & i + 1).Value = yaz


End If
Next i

Dener misiniz

 

[Harun_Y]

Dim ara As String
Dim yaz As String
sonsatir = Range("A65536").End(xlUp).Row


ara = InputBox("Aranacak Deger", "Aranacak Degeri Yaz")

For i = 2 To sonsatir

If Range("A" & i).Value = ara Then

Range("A" & i + 1).EntireRow.Insert
Range("A" & i + 1).Select
yaz = InputBox("Yazilacak Deger", "Yazilacak Degeri Yaz")
Range("A" & i + 1).Value = yaz


End If
Next i

Dener misiniz

Teşekkür ederim ustam ufkumu açtınız ve işime yaradı lakin her bulduğu aynı kelimede sormasa tümüne uygulasa olabilir mi? Örneğin Her Ankara yı bulduğunda alt satırına ne yazalım diye soruyor Tüm ankaralara uygulayabilir miyiz

 

[Korhan Ayhan]

Deneyiniz.

A sütunu için kurgulanmıştır.

Option Explicit

Sub Insert_Row()
    Dim Search_Data As Variant, Find_Data As Range
    Dim New_Data As Variant, Old_Address As String
    
    Search_Data = InputBox("Lütfen aradığınız veriyi giriniz...")
    
    If Search_Data = "" Or Search_Data = False Then
        MsgBox "İşleme devam etmek için aradığınız veriyi girmelisiniz!", vbExclamation
        Exit Sub
    End If
    
    New_Data = InputBox("Lütfen eklemek istediğiniz veriyi giriniz...")
    
    If New_Data = "" Or New_Data = False Then
        MsgBox "İşleme devam etmek için eklemek istediğiniz veriyi girmelisiniz!", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set Find_Data = Range("A:A").Find(Search_Data, Cells(Rows.Count, 1), , xlWhole)
    If Not Find_Data Is Nothing Then
        Old_Address = Find_Data.Address
        Do
            Find_Data.Offset(1).EntireRow.Insert
            Find_Data.Offset(1) = New_Data
            Set Find_Data = Range("A:A").FindNext(Find_Data)
        Loop While Not Find_Data Is Nothing And Find_Data.Address <> Old_Address
    End If

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub