• DİKKAT

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

Aramak ve Bulunan veriyi başka bir sayfaya yazmak

T

tamersonmez

Katılım
5 Kasım 2007
Mesajlar
10
Excel Vers. ve Dili
Dil Türkçe
versiyon 2002
Üstadlar elimde bir tablo var ve yaklaşık satır sayısı 50.000 dir.( toblonun bir örneği ekte mevcuttur) Bu tabloda A stünunda ve içinde Luk kelimesi geçen hücreleri bulmak ve hücrenin bulunduğu satırın tamamını sayfa2 ye olduğu gibi eklemek istiyourum.Acil yardımlarınızı beklemekteyim.

Herkese şimdiden teşekkürler...
 

Ekli dosyalar

dosyanız ektedir.:cool:
Kod: 
Sub lukluk_59()
Dim sh As Worksheet, sat As Long, i As Long, sat1 As Long
Dim k As Range, adr As String
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
sh.Range("A2:C65536").ClearContents
Sheets("Sayfa1").Select
sat1 = 2
sat = Cells(65536, "A").End(xlUp).Row
Set k = Range("A2:A" & sat).Find("luk", , xlValues, xlPart)
If Not k Is Nothing Then
    adr = k.Row
    Do
        sh.Range("A" & sat1 & ":C" & sat1).Value = Range("A" & k.Row & ":C" & k.Row).Value
        sat1 = sat1 + 1
        Set k = Range("A2:A" & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Row <> adr
End If
sh.Select
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "İşlem sonuçlanmıştır!", vbOKOnly + vbInformation, "BİTTİ"
End Sub
 

Ekli dosyalar

Merhaba,

Süz ve Aktar mantığı ile alternatif çözüm.

Kod: 
Sub Suz_ve_Aktar()
    Dim i   As Long, _
        s2  As Worksheet
    
    Sheets("Sayfa1").Select
    Range("A1").Activate
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    
    i = Cells(Rows.Count, "A").End(3).Row
    Selection.AutoFilter
    ActiveSheet.Range("A1:C" & i).AutoFilter Field:=1, Criteria1:="=*luk*", _
        Operator:=xlAnd
        
    Range("A1").CurrentRegion.Copy s2.Range("A1")
    MsgBox "İşlem Tamam..."
End Sub
 

Ekli dosyalar

Necdet Yeşertener' Alıntı:
Merhaba,

Süz ve Aktar mantığı ile alternatif çözüm.

Kod: 
Sub Suz_ve_Aktar()
    Dim i   As Long, _
        s2  As Worksheet
    
    Sheets("Sayfa1").Select
    Range("A1").Activate
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    
    i = Cells(Rows.Count, "A").End(3).Row
    Selection.AutoFilter
    ActiveSheet.Range("A1:C" & i).AutoFilter Field:=1, Criteria1:="=*luk*", _
        Operator:=xlAnd
        
    Range("A1").CurrentRegion.Copy s2.Range("A1")
    MsgBox "İşlem Tamam..."
End Sub
Genişletmek için tıkla ...

Sayın Necdet ustadım.Sizin yönteminizde işime çok yaradı.Kolon sayısı 3 den fazla olan verileride bu sayede basitçe süzmekteyim.Diğer üstadımın yapmış olduğu örnek tabloda sadece 3 tane stünun verilerini sayfa 2 aktarmakta idi.Sütün sayısı fazla olduğunda arta kalan satırları aktarmamakta idi,Bu açığı sizin yazdığınız kodlarla aştım.Teşekkür ederim
 
tamersonmez' Alıntı:
Sayın Necdet ustadım.Sizin yönteminizde işime çok yaradı.Kolon sayısı 3 den fazla olan verileride bu sayede basitçe süzmekteyim.Diğer üstadımın yapmış olduğu örnek tabloda sadece 3 tane stünun verilerini sayfa 2 aktarmakta idi.Sütün sayısı fazla olduğunda arta kalan satırları aktarmamakta idi,Bu açığı sizin yazdığınız kodlarla aştım.Teşekkür ederim
Genişletmek için tıkla ...

Güle güle kullanınız, hız açısından yorum yaparsanız sevinirim. Az veri ile pek belli olmuyor çünkü.
 
Emeği geçen arkadaşlara teşekkürler. Sn Necdet bey eğer luk yerine a stununda herhangi bir hücreyi seçtiğimizde süz ve aktar demek isteseydik kodları ne şekilde yazmalıyız.

iyi bayramlar, şimdiden teşekkürler....
 
Sayın Orion1 ve Necdet Yeşertener,

Katkılarınız için teşekkür eder, Ramazan bayramınızı kutlarım.

Sevgi ve saygılar.
 
relaxim' Alıntı:
Emeği geçen arkadaşlara teşekkürler. Sn Necdet bey eğer luk yerine a stununda herhangi bir hücreyi seçtiğimizde süz ve aktar demek isteseydik kodları ne şekilde yazmalıyız.

iyi bayramlar, şimdiden teşekkürler....
Genişletmek için tıkla ...

Merhaba,

Aşağıda Kırmızı ile belirlediğim değişiklikleri yapmak yeterli. Önce A sütununda herhangi bir hücreye tıklayacaksınız (seçeceksiniz), sonra kodları çalıştıracaksınız.

Kod: 
Sub Suz_ve_Aktar()
    Dim i   As Long, _
        [B][COLOR=red]Deg As String[/COLOR][/B], _
        s2  As Worksheet
    
    [COLOR=red][B]Deg = "=*" & ActiveCell.Value & "*"
[/B][/COLOR]    
    Sheets("Sayfa1").Select
    Range("A1").Activate
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    
    i = Cells(Rows.Count, "A").End(3).Row
    Selection.AutoFilter
    ActiveSheet.Range("A1:C" & i).AutoFilter Field:=1, Criteria1:=[COLOR=red][B]Deg[/B][/COLOR], _
        Operator:=xlAnd
        
    Range("A1").CurrentRegion.Copy s2.Range("A1")
    MsgBox "İşlem Tamam..."
End Sub
 
Sn Necdet bey teşekkürler. Gayet güzel çalışıyor. Küçük bir ricam daha olacak; komut çalıştığında sayfa1 deki süzme olayı çözülüp sayfa eski haline gelmeli, sayfa2 etkin halde olmalı... Bunu da yaparsanız minnettar kalırım. Şimdiden teşekkürler....
 
relaxim' Alıntı:
Sn Necdet bey teşekkürler. Gayet güzel çalışıyor. Küçük bir ricam daha olacak; komut çalıştığında sayfa1 deki süzme olayı çözülüp sayfa eski haline gelmeli, sayfa2 etkin halde olmalı... Bunu da yaparsanız minnettar kalırım. Şimdiden teşekkürler....
Genişletmek için tıkla ...

Merhaba,

Kodda aşağıdaki değişiklikle isteğiniz gerçekleşir.

Kod: 
Sub Suz_ve_Aktar()
 
    Dim i   As Long, _
        [COLOR=red]Deg As String[/COLOR], _
        s2  As Worksheet
    
   [COLOR=blue] If ActiveCell.Row < 2 Then Exit Sub
[/COLOR]    
    [COLOR=red]Deg = "=*" & ActiveCell.Value & "*"
[/COLOR]    
    Sheets("Sayfa1").Select
    Range("A1").Activate
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    
    i = Cells(Rows.Count, "A").End(3).Row
    Selection.AutoFilter
    ActiveSheet.Range("A1:C" & i).AutoFilter Field:=1, Criteria1:=[COLOR=red]Deg[/COLOR], _
        Operator:=xlAnd
        
    Range("A1").CurrentRegion.Copy s2.Range("A1")
[COLOR=blue]    Selection.AutoFilter
    s2.Select
[/COLOR]    MsgBox "İşlem Tamam..."
    
End Sub
 
Sn Necdet Bey çoook teşekkürler. Bu haliyle işimi görüyor.
Fakat ileride veriler çoğalınca hepsini tekrar aktarmak yerine sadece olmayanları aktarsın istersek veya sadece seçtiğimiz ay veya tarih aralığını (ikinci bir kriter devreye giriyor, tarih B sütununda) aktarsın diye düşünürsek ne yapabiliriz. (Not: Kayıtlar benzersizdir.)

Acaba yeni konu mu açmam lazım.....Yoksa bu konunun ilerletilmiş hali olarak devam etmesi mi uygun olur...

Siz nasıl uygun görürseniz o şekilde devam ederiz.

Şimdiden teşekkürler....
 
Güncel

relaxim' Alıntı:
Sn Necdet Bey çoook teşekkürler. Bu haliyle işimi görüyor.
Fakat ileride veriler çoğalınca hepsini tekrar aktarmak yerine sadece olmayanları aktarsın istersek veya sadece seçtiğimiz ay veya tarih aralığını (ikinci bir kriter devreye giriyor, tarih B sütununda) aktarsın diye düşünürsek ne yapabiliriz. (Not: Kayıtlar benzersizdir.)

Acaba yeni konu mu açmam lazım.....Yoksa bu konunun ilerletilmiş hali olarak devam etmesi mi uygun olur...

Siz nasıl uygun görürseniz o şekilde devam ederiz.

Şimdiden teşekkürler....
Genişletmek için tıkla ...

Konu arada kayboldu sanırım.....
 
Merhaba,

Örnek dosya olsa iyi olurdu :)
 
Örnek dosya eklendi.

örnek dosyayı ekledim. Soruyu biraz değiştirdim. GENEL sayfasından A sütunundan bir firma seçilince sayfa adı o firmanın adı olacak şekilde yeni bir sayfa açsın. Aynı adlı sayfa varsa yeni verileri eklesin. Şimdiden teşekkürler.
 

Ekli dosyalar

Son düzenleme:
Güncel

relaxim' Alıntı:
örnek dosyayı ekledim. Soruyu biraz değiştirdim. GENEL sayfasından A sütunundan bir firma seçilince sayfa adı o firmanın adı olacak şekilde yeni bir sayfa açsın. Aynı adlı sayfa varsa yeni verileri eklesin. Şimdiden teşekkürler.
Genişletmek için tıkla ...

Konu güncellenmiştir.
 
Merhaba,

Aşağıdaki kodlar Süzülmüş olan veriyi ilgili sayfaya aktarır.
Umarım işinize yarar.

Kod: 
Sub Suz_ve_Aktar()
 
    Dim SonSat  As Long, _
        Olcut   As String, _
        s2      As Worksheet
    
    Sheets("GENEL").Select
    With Sheets("GENEL")
        If .AutoFilterMode Then
            With .AutoFilter.Filters(1)
                If .On Then Olcut = .Criteria1
            End With
        End If
    End With
    If Olcut = "" Then Exit Sub
    Olcut = Replace(Olcut, "=", "")
    
    If Not SayfaVarMi(Olcut) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Olcut
        Sheets("GENEL").Select
    End If
    
    Range("A1").Activate
    
    Set s2 = Sheets(Olcut)
    On Error Resume Next
    SonSat = s2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    If SonSat = 0 Then SonSat = 1
    Range("A1").CurrentRegion.Copy s2.Range("A" & SonSat)
    If SonSat > 1 Then s2.Rows(SonSat).Delete
    MsgBox "İşlem Tamam..."
    
End Sub

Kod: 
Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function
 

Ekli dosyalar

Sn Necdet Bey ilgi ve alakanız için teşekkür ederim. Süzülen değilde daha önceki örnekte olduğu gibi seçtiğimiz hücredeki firmaya göre verileri aktarsa çok daha kullanışlı olurdu. Şu anda bir önceki yazdığınız kodlara göre kullanıyorum. Amacım firmaları sınıflandırıp, verileri aktarmak. Her biri için sayfa yapmayacağım. Tekrar teşekkürler....
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst