• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile kelime bulup sonraki 8 satır silmek/sonra ara ile işlemi tekrarlamak

O

ozanyazar

Katılım
8 Aralık 2009
Mesajlar
59
Excel Vers. ve Dili
Excel 2002
Türkçe
Satır silmek istiyorum ama belli bir kelimeyi arattırıp o kelimenin bulunduğu satırdan itibaren 8 satırı silmem ve tekrar (içeriği silinmiş satırlar yerine) 8 satır eklemem gerekli.

Excel sayfasında aradığım kelime "ÇEVRE", bu kelimeden sonra 8 satır seçtiğimde üst menüden SATIR SİL ve SATIR EKLE butonlarına bastığımda istediğim oluyor ama bunu çok fazla sayıda yapmam gerektiğinden bir makro ihtiyacım var.

Vaktiniz olur da bakabilirseniz memnun olurum.
 
Selamlar,

Aşağıdaki kod sayfada "ÇEVRE" kelimesini arar. Bulduğu satırın bir altından itibaren sekiz satırın içeriğini sadace A sütununda temizler.

Arama içerir mantığına göre yapılmaktadır. Eğer birebir eşleşme istiyorsanız kod içindeki kırmızı bölümü xlWhole olarak değiştirin.

Kod: 
Option Explicit
 
Sub KELİME_ARA_8_SATIR_SİL()
    Dim BUL As Range, ADRES As String
    
    Set BUL = Cells.Find("ÇEVRE", , , [COLOR=red]xlPart[/COLOR])
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        Range("A" & BUL.Row + 1 & ":A" & BUL.Row + 8).ClearContents
    
    Set BUL = Cells.FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
İlgilendiğiniz için teşekkürler, hemen denedim
" Birleştirilmiş bir hücrenin parçası değiştirilemez "
mesajı verdi

+ not: Bulduğum kelimenin satırı da dahil 8 satır silmem gerekiyor.
 
Selamlar,

Lütfen örnek dosya eklermisiniz.
 
Aramadan sonra 8 Satır silme

Resimleri silen makro aşağıda, ek olarak başlıkları silmem
yandaki satırlarda T.C.'yı arattıracağım,
sonraT.C'den itibaren 8 Satır (sarı renkli kısım dahil) seçip
bir kere satır sile/sonra satır ekleye basıyorum
8 adet boş satır geri gelsin düzen bozulmasın diye
Makro ile olması şu açıdan önemli, bazı dosyalarda 14 sayfaya kadar çıkıyor
ve her sayfada bu işlem çok sayıda istasyon için gerekli
Bu nedenle hem makro olmalı hem de tek bir dosyada değil, excelin tamamında çalışmalı.
Vaktiniz olursa şimdiden teşekkürler
 

Ekli dosyalar

Az önce boş bir hücreyi kopyalayıp T.C.'dan itibaren seçtiğim 8 satıra yapıştırdığımda da istediğim hale geldi.
T.C.yi ara bir üstteki boş hücreyi 8 satıra (SATIR SEÇEREK) yapıştır
şeklinde bir makro imkanı varsa o da işimi görür.
Ben dedeyince ilk yaptığımdaki satırların numaralarını alıyor ve makroyu her çalıştırmamda aynı satıra uygulamaya kalkıyor, yani işe yaramıyor.
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub RESİMLERİ_VE_BAŞLIKLARI_SİL()
    Dim SAYFA As Worksheet, RESİM As Shape
    Dim BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False
    
    For Each SAYFA In ThisWorkbook.Worksheets
        For Each RESİM In SAYFA.Shapes
            RESİM.Delete
        Next
    
        Set BUL = SAYFA.Cells.Find("T.C.", , , xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            If BUL.Row > 10 Then SAYFA.Range("A" & BUL.Row & ":M" & BUL.Row + 7).Clear
        Set BUL = SAYFA.Cells.FindNext(BUL)
        If WorksheetFunction.CountIf(SAYFA.Range("A:M"), "T.C.") = 1 Then Exit Do
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next
    
    Set BUL = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Çok teşekkür ediyorum bir soru daha sorarsam umarım ayıp olmaz.
Arkadaşla denerken ilk başlık kalmasını sağladığımızdan bahsetmek aklıma gelmemiş. ve bizim denenemizde bütün dosyadaki reimleri siliyordu ama sadece bulunduğumuz çalışma sayfasındaki başlıkları (1.si hariç) silebiliyordu.

Sizin yaptığınızda dosyadaki tüm çalışma sayfalarındakini sildiğinden daha vakit kazandırıyor.
Eğer mümkünsa "T.C." yı ilki hariç arattırıp işlem yapabilirsek, (mesela 10. satırdan itibaren) ilk başlık satırlarının silinmemesini de sağlamış oluruz ki bu beni ilk başlığı bir yere kopyalayıp, makrodan sonra geri yapıştırmak gibi bir hamallıktan da kurtarır.

Mümkünse rica ediyorum, vaktiniz olmasa da yaptığınız makro için çok teşekkürler.


Sizinkinden sonra gerek yok ama bakmak isterseniz arkadaşla denediğimiz makro;

Sub ahmet()

'''Sub DelPics()
For i = 1 To Worksheets.Count
For j = Worksheets(i).Shapes.Count To 1 Step -1
Worksheets(i).Shapes(j).Delete
Next
Next
Cells.Find(What:="T.C", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate


Dim x, s
' For s = 1 To 5 *
For x = 2 To [D65526].End(3).Row Step 1
If Cells(x, 1) Like "*T.C*" Then
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Delete
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert
Rows(x).Insert


End If
Next x
' Next s

End Sub
 
Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.
 
Maalesef çalışmadı

Hata vermeden "İşleminiz tamamlanmıştır mesajı" na kadar geliyor ama işlem yapmıyor



Not : Toplantı için çağırdılar, dönüşte bakacağım.
Vaktinizi fazla aldıysam kusura bakmayınız,
sağlıcakla kalınız.
 
Çok teşekkür ediyorum Korhan bey, aşağıdaki haliyle tamamlandı


Sub ahmet()

'''Sub DelPics()
For i = 1 To Worksheets.Count
For j = Worksheets(i).Shapes.Count To 1 Step -1
Worksheets(i).Shapes(j).Delete
Next
Next
Cells.Find(What:="T.C", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate

Dim x, s
For i = 1 To Worksheets.Count
For x = 2 To [D65526].End(3).Row Step 1
If Worksheets(i).Cells(x, 1) Like "*T.C*" Then
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Delete
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
End If
Next x
Next i
Range("A12").Select
MsgBox "İşlem tamamlandı", vbInformation
End Sub
 
Selamlar,

Benim önerdiğim kodda olumlu sonuç veriyordu. Deneyerek göndermiştim. Tabiki tercih sizin dilediğinizi kullanabilirsiniz.
 
Korhan Ayhan' Alıntı:
Selamlar,

Benim önerdiğim kodda olumlu sonuç veriyordu. Deneyerek göndermiştim. Tabiki tercih sizin dilediğinizi kullanabilirsiniz.
Genişletmek için tıkla ...

Korhan bey, yeni yeni makroyla uğraştığım için bir yerleri yanlış yapıştırmış olabilirim, acemiliğime verin. Vakit ayırdığınız için gönülden teşekkürler.

Şimdi de tüm çalışma sayfalarını "SAYIYA ÇEVİR" işlemine tutmaya çalışıyorum,
deneme yanılmalarım devam ediyor.
Sağlıcakla kalınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst