• DİKKAT

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

sayfa1 de bulduğu hücreyi belirli bir dizini diğer sayfaya aynı konum olarak almak için makro ihtiyacım var

I

idealimsin

Katılım
2 Ekim 2011
Mesajlar
356
Excel Vers. ve Dili
excel 360 TR 64bit
sayfa1 de bulduğu hücreyi örnek( April 16 ) belirli bir dizin olarak (aranan hücre genelde sayfada 10 ile 20 adet arasında oluyor) yani aranan hücreyi bulduğunda örnek( B8 hücresinde buldu ) ve bulduğu hücreyi (B5:Q35) dizin olarak kopyalayıp diğer sayfada aynı boş bir sütuna kopyalasın YANİ (B..:Q..) olarak ,satırı önemli değil .diğer sayfaya almak için makro ihtiyacım var. yardımcı olabilirmisiniz
(aranan değer A,B,C,D,E sütunlarında var)
 

Ekli dosyalar

Tablonuz çok karışık olduğu için uğraşmak keyif vermiyor.
Sanırım sizin ihtiyacınız KAYDIR fonksiyonu.
 
Arama işleminden sonra diyelim ki veri D sütununda bulundu hangi aralık diğer sayfaya kopyalanacak?

Ayrıca aranan değerden sanırım birden fazla satırda var? Bu durumda nasıl işlem yapılacak?
 
Korhan Ayhan' Alıntı:
Arama işleminden sonra diyelim ki veri D sütununda bulundu hangi aralık diğer sayfaya kopyalanacak?

Ayrıca aranan değerden sanırım birden fazla satırda var? Bu durumda nasıl işlem yapılacak?
Genişletmek için tıkla ...
ayrıntılı olarak yazmıştım

sayfa1 de bulduğu hücreyi örnek( April 16 ) belirli bir dizin olarak (aranan hücre genelde sayfada 10 ile 20 adet arasında oluyor) yani aranan hücreyi bulduğunda örnek( B8 hücresinde buldu ) ve bulduğu hücreyi (B5:Q35) dizin olarak kopyalayıp diğer sayfada aynı boş bir sütuna kopyalasın YANİ (B..:Q..) olarak vey a bir örnek daha
örnek( E36 hücresinde buldu ) ve bulduğu hücreyi (E36:T35) dizin olarak kopyalayıp diğer sayfada aynı boş bir sütuna kopyalasın YANİ (E..:T..) olarak ,,satırı önemli değil .yeterki bulduğu sütunda diğer safayada kopyalasın .
(aranan değer A,B,C,,E F sütunlarında var)
evet aranan değer birden fazla var
 
İlk örneğinizde aranan değeri B sütununda bulunca B:Q arası kopyalanıyor. B8 de buluyor. Ama kopyalarken B5:Q35 olarak baz alınıyor. Bu alan neye göre belirleniyor.

İkinci örneğinizde E36 da buluyor. Fakat kopyalama işleminde E36:T35 alanı kullanılıyor. (Burada kafam yandı. Bir gariplik var gibi.)

İlk örnekte son sütun Q iken, ikinci örnekte T oldu.

Bence örnek dosyanızda görmek istediğiniz sonucu da paylaşırsanız konu daha net anlaşılacaktır.
 
B8 hücresinde buldu (B5:Q35) dizin kadar veri içeriyor. yani 16 sütun ve 30 satır olan dizini kopyalayacak. ikinci örnek verdiğimde aynı mantıkta. E8 hücresinde buldu (E8:T35) dizin kadar 16 sütun ve 30 satır olan dizini kopyalayacak. (E36:T35 bu rakam klavye hatası oldu)
 
March 27 için dosyanızda örnekler misiniz?
 
tarihler değişken olacak. makroya tarihi eli le girip çalıştırmam gerekiyor
 

Ekli dosyalar

Kendinize uyarlarsınız.

C++: 
Option Explicit

Sub Bul_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range
    Dim Adres As String, Aranan As Variant, Satir As Long
   
    Aranan = Application.InputBox("Aradığınız veriyi giriniz.", "Aranan Veri")
    If Aranan = "" Or Aranan = False Then Exit Sub
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
   
    S2.Cells.Clear
    Satir = 1
   
    Set Bul = S1.Cells.Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Bul.Offset(-2).Resize(30, 16).Copy S2.Cells(Satir, Bul.Column)
            Satir = Satir + 35
           
            Set Bul = S1.Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
                   
    MsgBox "Bulunan veriler aktarılmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Kendinize uyarlarsınız.

C++: 
Option Explicit

Sub Bul_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range
    Dim Adres As String, Aranan As Variant, Satir As Long
 
    Aranan = Application.InputBox("Aradığınız veriyi giriniz.", "Aranan Veri")
    If Aranan = "" Or Aranan = False Then Exit Sub
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    S2.Cells.Clear
    Satir = 1
 
    Set Bul = S1.Cells.Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Bul.Offset(-2).Resize(30, 16).Copy S2.Cells(Satir, Bul.Column)
            Satir = Satir + 35
         
            Set Bul = S1.Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
                 
    MsgBox "Bulunan veriler aktarılmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
çok teşekkür edrim elinize sağlık. mesela ."April 16" diye arattırdığımda çalışma dosyasında yeni bir sayfa açıp "April 16" diye sayfa adı yazabilirmi.?
 
Deneyiniz.

C++: 
Option Explicit

Sub Bul_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range, Say As Long
    Dim Adres As String, Aranan As Variant, Satir As Long
   
    Aranan = Application.InputBox("Aradığınız veriyi giriniz.", "Aranan Veri")
    If Aranan = "" Or Aranan = False Then Exit Sub
   
    Set S1 = Sheets("Sayfa1")
   
    Satir = 1
   
    Set Bul = S1.Cells.Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
       
        On Error Resume Next
        Set S2 = Nothing
        Set S2 = Sheets(Aranan)
        On Error GoTo 0
       
        If S2 Is Nothing Then
            Set S2 = Sheets.Add(, Sheets(Sheets.Count))
            S2.Name = Aranan
        Else
            S2.Cells.Clear
        End If
       
        Do
            Bul.Offset(-2).Resize(30, 16).Copy S2.Cells(Satir, Bul.Column)
            Say = Say + 1
            Satir = Satir + 35
           
            Set Bul = S1.Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
                   
    If Say > 0 Then
        MsgBox "Bulunan veriler aktarılmıştır.", vbInformation
    Else
        MsgBox "Aranan veri bulunamadı!" & Chr(10) & Chr(10) & _
               "Aranan veri ; " & Aranan, vbCritical
    End If
End Sub
 
Üstteki kodu güncelledim. Tekrar deneyiniz.
 
Korhan Ayhan' Alıntı:
Üstteki kodu güncelledim. Tekrar deneyiniz.
Genişletmek için tıkla ...
hocam herşey için çok teşekkürler çok iyi çalışıyor. ekstra şöyle bir şey yapıyor. diyelim "january 1 " arattırıyorum. fazladan january 11 ,january 13 january 10 lu hücreleride aktarıyor. birde sayfa1 de aktardığı hücreyi yani örnek "january 1" renklendebilirse aktardığı hücreyi rahatlıkla ayırtedmemi sağlaması açısından olabilirmi?
 
Aramam işlemi içerir mantığı ile olduğundan January 11 içinde January 1 ifadesi geçtiğinden bu şekilde sonuç oluşuyor.

Dilerseniz tam eşleşme sağlanabilir. Fakat bu durumda hücredeki veriyi aynen yazmanız gerekecektir.

Renklendirme olayı için birazdan dönüş yaparım.
 
Deneyiniz.

Yine içerir mantığı ile arama yapar.

Sayfa1'de koşullu biçimlendirme var. Onları silerseniz yapılan sarı renklendirmeyi görebilirsiniz.

Eğer arama işlemi içerir olmasın derseniz kod içindeki aşağıdaki kırmızı bölümü xlWhole olarak değiştiriniz.

Set Bul = S1.Cells.Find(Aranan, , , xlPart)


C++: 
Option Explicit

Sub Bul_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range, Say As Long
    Dim Adres As String, Aranan As Variant, Satir As Long
   
    Aranan = Application.InputBox("Aradığınız veriyi giriniz.", "Aranan Veri")
    If Aranan = "" Or Aranan = False Then Exit Sub
   
    Set S1 = Sheets("Sayfa1")
   
    Satir = 1
   
    Set Bul = S1.Cells.Find(Aranan, , , xlPart)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
       
        On Error Resume Next
        Set S2 = Nothing
        Set S2 = Sheets(Aranan)
        On Error GoTo 0
       
        If S2 Is Nothing Then
            Set S2 = Sheets.Add(, Sheets(Sheets.Count))
            S2.Name = Aranan
        Else
            S2.Cells.Clear
        End If
       
        Do
            Bul.Interior.ColorIndex = 6
            Bul.Offset(-2).Resize(30, 16).Copy S2.Cells(Satir, Bul.Column)
            Say = Say + 1
            Satir = Satir + 35
           
            Set Bul = S1.Cells.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
                   
    If Say > 0 Then
        MsgBox "Bulunan veriler aktarılmıştır.", vbInformation
    Else
        MsgBox "Aranan veri bulunamadı!" & Chr(10) & Chr(10) & _
               "Aranan veri ; " & Aranan, vbCritical
    End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst