• DİKKAT

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

sayfalar arası aratma kopyala yapıştır

  • Konbuyu başlatan Konbuyu başlatan masue
  • Başlangıç tarihi Başlangıç tarihi
M

masue

Katılım
12 Mart 2018
Mesajlar
34
Excel Vers. ve Dili
excel 2016
herkese mrhblar;

Forumunuzu epey bir zamandan takip ediyorum.hocalarımızın ve diğer arkadaslarımız sayesinde bilgilerden ve deneyimlerden fazlasıyla yararlanıyoruz.sorunlarımız en hızlı çözümü forumda çok şükür bulabiliyoruz.bu yüzden bütün hocalaırımıza ve forum a çok teşekkür ederiz.

karşılaştığım bir sorunla forumunuzun ve hocalarımızın yine yardımcı olabileceğini düşünüyorum.

ek de göndericeğim excel dosyasından;
1 sayfa veri tabanım oluyor.sarı ile boyalı alan benim ürünlerimin kodları.
kırmızı boyalı alan ise ürünlerin diğer referans numaraları.yapmak istediğim 2 sayfada herhangi bir hücreye referans numarasını yazıp 1 sayfadaki bütün ürünlerim arasından referansın olduğu ilgili satırı alıp 3 sayfaya yapıştırmak.bir nevi 2 sayfayı arama motoru gibi kullanıp 3 sayfaya ilgili satırı yapıştırmak.şimdiden ilgi ve alakanız için teşekkür eder.yardımlarınızı beklemekteyim.herkese kolay gelsin.
http://dosya.co/2isepa0m72za/örnek_dosya.xls.html
 
sayfa 2 de girilen veriyi sayfa 1 de bul ilgili satırı sayfa 3 e yapıştır

sayfa 2 de girilen veriyi sayfa 1 de bul ilgili satırı sayfa 3 e yapıştır
 
"Sayfa2" isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

Herhangi bir hücreye yazdığınız veri aranacaktır. Bulunursa "Sayfa3" isimli sayfaya kopyalanacaktır.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, BUL As Range
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    Set BUL = S1.Cells.Find(Target.Value, , , xlWhole)
    If Not BUL Is Nothing Then
        BUL.EntireRow.Copy S3.Range("A1")
        S3.Select
    Else
        MsgBox "Aranan kayıt bulunamadı!", vbCritical
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
End Sub
 
Sn.Korhan hocam, aranan kriterin listelenmesini istersek (birden fazla olması durumunda) kodda nasıl bir değişiklik yapmalıyız. Teşekkürler.
 
yapmam gereken değşiklik nedir acaba

hocam ilgi alakanız,ayırdığınız değerli zamanınız için teşekkür ederim.yalnız arkadaşın da dediği gibi 2.sayfa da A sütununa altalta 1 den fazla veri yazıp 1.SAYFADA aratmak istiyorum.sadece a1 hücresi için ara değil de a sütunu için 1.SAYFADA arama yapmak istiyorum.arama sonucunda da 1 sayfada süzülen satırlar 3 sayfaya kopyalanıp yapışsın istiyorum.bir bakıma çoklu bir kopyala yapıştır gerçekleşmeli.1 SAYFAMDAKİ VERİ SATIR SAYIM 50000 ÜSTÜ.Hocam cok şey mi istyorum bilmiyorum ama.makro olayına yeni başlamış biriyim.şimdiden ilginize teşekkür ederim
 
Son düzenleme:
Detayda verinizin tekrar edebileceğini belirtmediğiniz için tek kayıt olarak kurgulamıştım.

Aşağıdaki kod ile çoklu listeleme yapabilirsiniz.

Verilerinizde başlık görünmüyor. Sayfalarınızda başlık varsa daha farklı kodlama yazılabilir.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim BUL As Range, Adres As String, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    S3.Cells.Delete
    Satir = 1
    
    Set BUL = S1.Cells.Find(Target.Value, , , xlWhole)
    If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
            BUL.EntireRow.Copy S3.Cells(Satir, 1)
            Satir = Satir + 1
            Set BUL = S1.Cells.FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        S3.Select
    Else
        MsgBox "Aranan kayıt bulunamadı!", vbCritical
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Hocam öncelikle ilgilenip cevap verdiğiniz için çok teşekkür ederim.Dediğiniz gibi eksiklikler benim sorunu ayrıntılı,tam anlamıyla ifade edememden kaynaklı.lakin şuan 2.sayfada sıralı veri girip,arama yapabiliyorum ama 3. sayfaya tek satır olarak sadece 2.sayfada tıkladığım kodu veriyor.Benim ihtiyacım olan 2.sayfaya A sütununa yazdığım kodların aynı sırada 3 sayfada hepsinin karşılığını vermesi.bir nevi çeviri yapıyorum.Tekrar ilginize teşekkür eder iyi çalışmalar dilerim.
 
Son düzenleme:
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim BUL As Range, Adres As String, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    S3.Cells.Delete
    Satir = 1
    For i = 1 To Range("A1048576").End(xlUp).Row
    
    Set BUL = S1.Cells.Find(Range("a" & i).Value, , , xlWhole)
    If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
            BUL.EntireRow.Copy S3.Cells(Satir, 1)
            Satir = Satir + 1
            Set BUL = S1.Cells.FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        S3.Select
    Else
        MsgBox "Aranan kayıt bulunamadı!", vbCritical
    End If
    Next
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

bu kodu denermisiniz
birde kodu buton ile çalıştırmak daha mantıklı bence.
bu şekilde işlem yapmak zor oluyor.
aratacaklarınızın hepsini yazıp butona basarsınız.
 
Son düzenleme:
Hocam ağzın bal yesin.butonu belirticektim de cok sey istiyor gibi olur diye yazamamistim.forumdaki butun uzman arkadaslar olsun herkes yardimci olmaya calisiyorlar saolsunlar.forumda verilen emek ve zamana buyuk saygi duyuyorum.butonu 2 sayfaya revize edip ekleybilirmisiniz rica etsem.dediğiniz gibi büyük kolaylık olur benim için.şimdiden teşekkür ederim.kolayliklar dilerim.
 
Son düzenleme:
arkadaşlar buton eklemek yada manuel şekilde çalıştırmak için ne ekleme yapmam lazım acaba.birde 2 .sayfada yazdığım verilerin altında boşluklar olabiliyor.boş olan hücreyi atlaması lazım
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst