arama yapmak

[dgnzcn]

arkadaşlar hepinize merhaba.

4-5 bin adet satırı olan bir excel dosyam var.

bu dosyadaki denizli ismi geçen satırları aratıp kopyalamak ve yeni bir excel sayfasına yapıştırmak istiyorum.

arama yapınca denizli ismi geçen kelimeleri buluyor. ben denizli kelimesinin geçtiği satırları komple koplayamak istiyorum. bunu nasıl yapabilirim.

 

[Orion1]

ctrl+F==>Aranan yazan yere denizli yazın.Sonrada tümünü Bul'a basın işlem tamamdır.

 

[dgnzcn]

ctrl+F==>Aranan yazan yere denizli yazın.Sonrada tümünü Bul'a basın işlem tamamdır.

hızlı cevap için teşekkürler ama bundan sağlıklı sonuç alamadım.


ctrl + f ile arama yaptım. bütün denizli geçen kelimeleri bulup işaretledi ama ben istiyorumki içinde denizli geçen satırların tümünüde işaretlesin ve kopyalasın.

bunu nasıl yaparım ?

 

[Orion1]

hızlı cevap için teşekkürler ama bundan sağlıklı sonuç alamadım.


ctrl + f ile arama yaptım. bütün denizli geçen kelimeleri bulup işaretledi ama ben istiyorumki içinde denizli geçen satırların tümünüde işaretlesin ve kopyalasın.

bunu nasıl yaparım ?

O zaman makro yapalım.Bir tane örnek dosya ekleyin.Bakalım.

 

[dgnzcn]

hemen

örnek dosyayı ekledim.

 

[Orion1]

hemen

örnek dosyayı ekledim.

Dosyanız ekte.

Sub arama_59()
Dim deg, sat As Long, k As Range, adr As String, sat2 As Long
Sheets("rapor").Select
sat = 5
deg = InputBox("Aranacak Değeri Giriniz :", "ARAMA-59", "DENİZLİ")
If deg = "" Then Exit Sub
sat2 = Cells(65536, "B").End(xlUp).Row
deg = UCase(Replace(Replace(deg, "ı", "I"), "i", "İ"))
Application.ScreenUpdating = False
With Sheets("Çalışma Sayfası2")
    .Range("A5:J65536").ClearContents
    Set k = Range("G5:G" & sat2).Find(deg, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            .Range("A" & sat & ":J" & sat).Value = Range("A" & k.Row & ":J" & k.Row).Value
            sat = sat + 1
            Set k = Range("G5:G" & sat2).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    .Select
End With
Application.ScreenUpdating = True
MsgBox "AKTARMA TAMAMALANDI", vbOKOnly + vbInformation, Application.UserName
    
End Sub

 

[dgnzcn]

çok teşekkürler dostum.

sayfamdaki satırlar 3-5 bin adet demiştim.
bir kaç sorum var.

ofis 2007 enterprise türkçe kullanıcısıyım.

- aktar deyince orjinal dosya yokoluyor.
- asıl 3-5 bin satırlık dosyama bu makroyu nasıl entegre edebilirim ve aktar deyince aktar butonunun kaybolmasını istiyorum diğer aramalarımı yapmak için.
- aktar deyince farklı satırlardaki aktarmalarda aktarırken boşluk bırakırmı , aktarırken alt alta diziyormu ?
- ĞÜŞİÖÇışöçğü gibi harflerde sorun çıkarıyor galiba.
- aktarma işlemini pratikleştirmek için ( sayfamda 3000 - 5000 bin satır olduğunu düşünürsek ) aktar butonunun kaybolmaması için ne yapmak lazım

 

[Orion1]

çok teşekkürler dostum.

sayfamdaki satırlar 3-5 bin adet demiştim.
bir kaç sorum var.

ofis 2007 enterprise türkçe kullanıcısıyım.

- aktar deyince orjinal dosya yokoluyor.
- asıl 3-5 bin satırlık dosyama bu makroyu nasıl entegre edebilirim ve aktar deyince aktar butonunun kaybolmasını istiyorum diğer aramalarımı yapmak için.
- aktar deyince aradaki boşlukları otomatik yokediyormu ?

aktar deyince orjinal dosya nasıl yok oluyor?
Bu kodları yeni bir standart boş modüle kopyalarsanız kaç satır olursa olsun en son satıra kadar tarar bulduklarını aktarır.
Aktar butonunun niye kaybolmasını istiyorsunuz.Butona sağ tıklayıp butonu silebilirsinz.
Bu takdirde kodu Alt+F8 tuş kombonisyonuna basarak makroya çift tıklayarak çalıştırabilirsiniz.İsterseniz alt+f8 e bastıktan sonra makroyu seçip seçenekler butonuna basarak bir kısayol tuşuda atayabilirsiniz.
Aradaki boşluklar nedir.Bu direk İnputboxa yazdığınız değerleri bulur.
Önemli:G sütununda 5nci satırdan sonrasında birleştirilmiş hücre bulunmamalıdır.

 

[dgnzcn]

dostum kod gerçekten çok güzel olmuş. inceleyince kendi hatamdan kaynaklanan kullanım hatası olduğunu gördüm.
tekrar teşekkür ederim emeğine sağlık.


mevcut makroya şunları ilave etmek mümkün olurmu acaba ?

- aktarma işlemini yaparken her aktarmada açık tablodaki ilk 4 satırı standart olarak aktarsın. ( aradığım kelimeleri ayrı bir excel dosyası olarak kaydedicem. bu ilk 4 satır her dosyada başlık olarak kalsın ve 5. satırdan itibaren aranan satırlar eklensin )
- arama yapılan kelimeyi aktarırken kopyalama değil taşıma yapsın.
- tablodaki yazıtipi ve renk kodlarınıd ve hücre genişlik ve yüksekliklerinide taşısın

böyle birşey mümkünmü excelde ?

 

[dgnzcn]

bu verdiğiniz makroyu bir kere çalıştırdım. sonrasında hata verdi. beceremedim sanırım.

kendi excel dosyamda bu makroyu nasıl çalıştırırım.

 

[dgnzcn]

hata sorununu makronun aradığı kopyalanacak sayfayı bulamamasından verdiğini gördüm. aynı isimde sayfa oluşturdum. sorun çözüldü.



kopyalama yerine taşıma işlemini anlatırmısın sana zahmet ?

 

[Orion1]

dostum kod gerçekten çok güzel olmuş. inceleyince kendi hatamdan kaynaklanan kullanım hatası olduğunu gördüm.
tekrar teşekkür ederim emeğine sağlık.


mevcut makroya şunları ilave etmek mümkün olurmu acaba ?

- aktarma işlemini yaparken her aktarmada açık tablodaki ilk 4 satırı standart olarak aktarsın. ( aradığım kelimeleri ayrı bir excel dosyası olarak kaydedicem. bu ilk 4 satır her dosyada başlık olarak kalsın ve 5. satırdan itibaren aranan satırlar eklensin )
- arama yapılan kelimeyi aktarırken kopyalama değil taşıma yapsın.
- tablodaki yazıtipi ve renk kodlarınıd ve hücre genişlik ve yüksekliklerinide taşısın

böyle birşey mümkünmü excelde ?

İstediğiniz düzenlemeyi yaptım.
Dosya ektedir.
Not:Taşıdığı sayfada bütün sayfayı silip sıfırdan yani 5nci satırdan itibaren alt alta listeler.

Sub arama_59()
Dim deg, sat As Long, k As Range, adr As String, sat2 As Long
Dim col As Collection
Set col = New Collection
Sheets("rapor").Select
sat = 5
deg = InputBox("Aranacak Değeri Giriniz :", "ARAMA-59", "DENİZLİ")
If deg = "" Then Exit Sub
sat2 = Cells(65536, "B").End(xlUp).Row
deg = UCase(Replace(Replace(deg, "ı", "I"), "i", "İ"))
Application.ScreenUpdating = False
With Sheets("Çalışma Sayfası2")
    .Range("A:J").ClearContents
    Range("A1:J4").Copy
    .Range("A1").PasteSpecial xlPasteValues
    .Range("A1").PasteSpecial xlPasteAllExceptBorders
    .Range("A1").PasteSpecial xlPasteColumnWidths
    .Range("A1").PasteSpecial xlPasteFormats
    For i = 1 To 4
            .Range("A" & i).EntireRow.RowHeight = Range("A" & i).EntireRow.RowHeight
         Next i
    Application.CutCopyMode = False
    Set k = Range("G5:G" & sat2).Find(deg, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            Range("A" & k.Row & ":J" & k.Row).Copy .Range("A" & sat)
            .Range("A" & sat).EntireRow.RowHeight = Range("A" & k.Row).EntireRow.RowHeight
            col.Add k.Row
            sat = sat + 1
            Set k = Range("G5:G" & sat2).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    For i = 1 To col.Count - 1
        For j = i + 1 To col.Count
            If col(i) > col(j) Then
                x = col(i)
                col(i) = col(j)
                col(j) = x
            End If
        Next j
    Next i
    For i = col.Count To 1 Step -1
        Rows(col(i)).Delete
    Next
    .Select
    Application.ScreenUpdating = True
Range("A1").Select

        
MsgBox "AKTARMA TAMAMALANDI", vbOKOnly + vbInformation, Application.UserName
End With
    
End Sub

 

[dgnzcn]

senin verdiğin dosyadaki butonu kopyalayıp kendi dökümanıma yapıştırdım. butona basıp ok deyince runtime error 424 object required hatası verdi.

debug yapınca : col(i) = col(j) yazan satırı işaretledi.

 

[dgnzcn]

neyse dostum.biraz kurcalayarak çözdüm.

çok işime yaradı. eline emeğine sağlık.

 

[Orion1]

neyse dostum.biraz kurcalayarak çözdüm.

çok işime yaradı. eline emeğine sağlık.

O satırda hata vermemesi lazımdı.
Neyse çözüldüğüne göre problem yok.
İyi çalışmalar.