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

[idealimsin]

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)

 

[idealimsin]

Çözümü yokmudur bu yolun

 

[ÖmerFaruk]

Tablonuz çok karışık olduğu için uğraşmak keyif vermiyor.
Sanırım sizin ihtiyacınız KAYDIR fonksiyonu.

 

[idealimsin]

Tablonuz çok karışık olduğu için uğraşmak keyif vermiyor.
Sanırım sizin ihtiyacınız KAYDIR fonksiyonu.

anladım

 

[Korhan Ayhan]

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?

 

[idealimsin]

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?

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

 

[Korhan Ayhan]

İ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.

 

[idealimsin]

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)

 

[Korhan Ayhan]

March 27 için dosyanızda örnekler misiniz?

 

[idealimsin]

tarihler değişken olacak. makroya tarihi eli le girip çalıştırmam gerekiyor

 

[Korhan Ayhan]

Kendinize uyarlarsınız.

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

 

[idealimsin]

Kendinize uyarlarsınız.

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

ç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.?

 

[Korhan Ayhan]

Deneyiniz.

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

 

[idealimsin]

bu kodda bu hata yı geçemedim

 

[Korhan Ayhan]

Üstteki kodu güncelledim. Tekrar deneyiniz.

 

[idealimsin]

ellerinize sağlık Allah razıolsun

 

[idealimsin]

Üstteki kodu güncelledim. Tekrar deneyiniz.

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?

 

[Korhan Ayhan]

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.

 

[Korhan Ayhan]

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)

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

 

[idealimsin]

Ellerinize gözlerinize sağlık