• DİKKAT

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

Değişken hücrelerde köprü

  • Konbuyu başlatan Konbuyu başlatan swxtr
  • Başlangıç tarihi Başlangıç tarihi
S

swxtr

Katılım
4 Mart 2011
Mesajlar
77
Excel Vers. ve Dili
Türkçe-2016
Merhaba, arama yapılan ve diğer sayflardan sonuç getiren bir sayfada, gelen verinin ait olduğu sayfaya köprü yapmak istemekteyim.

A1 hücresine kelime yazılıyor ve makro arama yapıp B2-F2 den başayıp aşağıya doğru arama sonuçlarını listeliyor. O listelenen bilgilerde C2 den itibaren tıkladığım her hangi bir hücre beni geldiği sayfa/sütuna/hücreye köprüleyecek..
Örnek dosya linktedir. https://yadi.sk/d/r_ULA1rz3EoLcP
 
Son düzenleme:
Sorunuz afaki olduğu için cevap alamadığınızı sanıyorum.

Sorunuzu, gerçek belgenizle aynı yapıda örnek belgeyle destekleyiniz.
Bahsettiğiniz makronun da belge içerisinde olmasını sağlayınız.

Bir üye mutlaka öneride bulunacaktır.
.
 
Ömer BARAN' Alıntı:
Sorunuz afaki olduğu için cevap alamadığınızı sanıyorum.

Sorunuzu, gerçek belgenizle aynı yapıda örnek belgeyle destekleyiniz.
Bahsettiğiniz makronun da belge içerisinde olmasını sağlayınız.

Bir üye mutlaka öneride bulunacaktır.
.
Genişletmek için tıkla ...

Anlıyorum fakat dosyada 13 sayfa var, çok fazla bilgi var tek tek silip örnek şeyler yazmak imkansız gibi. Kodu ve bilgi aranan ekranı paylaşabilirim. Eğer yine imkanı yoksa bir süre uğraşmam lazım.. Koddan çıkar İnşallah.

Kod: 
Private Sub ToggleButton1_Click()
    If ToggleButton1.Value = False Then
        soru = Application.InputBox("Bu sayfa şifrelidir.", "Uyarı!")
        If soru = "............." Then
            Sayfa11.Visible = xlSheetVisible
            ToggleButton1.Caption = "TUTANAKLARI GİZLE"
                Else
            MsgBox "Parola yanlış", vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
            Exit Sub
        End If
        Else
            Sayfa11.Visible = xlSheetVeryHidden
            ToggleButton1.Caption = "TUTANAKLARI GÖSTER"
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim syf As Worksheet, evn As Range
    If Target.Address(0, 0) = "A1" Then
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    Sayfa13.Range("B2:M1000").ClearContents
    For Each syf In ThisWorkbook.Worksheets
        If Sayfa13.CheckBox1.Value = False And syf.Name = "DURUŞMA LİSTESİ" Then GoTo 20
        If Sayfa13.CheckBox2.Value = False And syf.Name = "ARŞİV" Then GoTo 20
        If Sayfa13.CheckBox3.Value = False And syf.Name = "İCRA" Then GoTo 20
        If Sayfa13.CheckBox5.Value = False And syf.Name = "MÜVEKKİL TEL. REHBERİ" Then GoTo 20
        
        If syf.Name <> "ARAMA SAYFASI" Then
           
                    Set evn = syf.Cells.Find(Target.Value & "*", , , 2, , , MatchCase:=False, SearchFormat:=False)
            If Not evn Is Nothing Then
                If syf.Cells(1, evn.Column).Value <> "DURUŞMA TARİHİ" Or syf.Cells(1, evn.Column).Value <> "YAPILACAKLAR" Then
                    ee = evn.Address
                    Do
                        Set evn = syf.Cells.FindNext(evn)
                        Sayfa13.Range("B65536").End(3)(2, 1) = syf.Name
                        syf.Range("A" & evn.Row & ":M" & evn.Row).Copy
                        Sayfa13.Range("C65536").End(3)(2, 1).PasteSpecial xlPasteValues
                    Loop While Not evn Is Nothing And ee <> evn.Address
                End If
            End If
        End If
       ' If syf.Name = "İCRA" Then GoTo 30
20    Next syf
    ActiveSheet.Range("$A$1:$J$17").RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
    For i = 2 To Range("B65536").End(3).Row
        If Cells(i, "F").Value = "" Then
            Cells(i, "F").Delete Shift:=xlToLeft
        End If
        If Cells(i, 2).Value = "İSTANBUL" And Cells(i, 5).Value = "" Then
            
            Range("F" & i & ":M" & i).Cut Destination:=Range("E" & i & ":L" & i)
          '  Cells(i, 5).Delete Shift:=xlToLeft
        End If
    Next i
    
    
    Dim bul As Range
    Range("B2:J" & Range("B5536").End(3).Row).Font.ColorIndex = 1
    For Each bul In Range("B2:J" & Range("B5536").End(3).Row).SpecialCells(xlCellTypeConstants, 2)
      renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Do
            If renk > 0 Then
                bul.Characters(Start:=renk, Length:=Len(Target.Value)).Font.ColorIndex = 3
            End If
            renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Loop While renk > 0
    Next bul
    Range("E:F").NumberFormat = "dd.mm.yyyy"
    
    If Sayfa13.CheckBox4.Value = False Then
        For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) = "1)" Or Len(Cells(a, "G").Value) < 2 Then
                Cells(a, "G").Value = ""
                Cells(a, "G").Delete Shift:=xlToLeft
            End If
        Next a
       Range("G1").Value = "SON DURUM"
       Range("H1").Value = ""
       Else
       Range("G1").Copy Range("h1")
       Range("G1").Value = "DURUŞMA TARİHİ"
       Range("H1").Value = "SON DURUM"
       For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) <> "1)" And Len(Cells(a, "G").Value) > 2 Then
                Range("G" & a & ":I" & a).Cut Destination:=Range("H" & a & ":J" & a)
            End If
        Next a
    End If
30    Application.EnableEvents = True
    Target.Activate
    MsgBox "Arama Tamamlanmıştır", vbInformation + vbMsgBoxRtlReading, "............."
    End If
End Sub


'
 

Ekli dosyalar

  • DD ARAMA EKRANI.jpg
    DD ARAMA EKRANI.jpg
    20.1 KB · Görüntüleme: 5
Son düzenleme:
Bu haliyle sayın OSMA'nın desteğini beklemek durumunda kalabilirsiniz.

Örnek belge olmadan verilecek fikirler genellikle;
yeni soru/sorunlara neden oluyor ve konunun gereksiz şekilde uzaması sonucunu doğuruyor.

Tercih sizin elbette, kolay gelsin.

NOT: Kod alıntılarını, cevap yazma ekranında,
sağ üstteki alanda yer alan # simgesine tıkladığınızda oluşacak CODE bloku arasına yapıştırmanız görüntü ve kullanım bakımından yerinde olur.
.
 
Ömer BARAN' Alıntı:
Bu haliyle sayın OSMA'nın desteğini beklemek durumunda kalabilirsiniz.

Örnek belge olmadan verilecek fikirler genellikle;
yeni soru/sorunlara neden oluyor ve konunun gereksiz şekilde uzaması sonucunu doğuruyor.

Tercih sizin elbette, kolay gelsin.

NOT: Kod alıntılarını, cevap yazma ekranında,
sağ üstteki alanda yer alan # simgesine tıkladığınızda oluşacak CODE bloku arasına yapıştırmanız görüntü ve kullanım bakımından yerinde olur.
.
Genişletmek için tıkla ...

Daha önce paylaşmışım içini değiştirdiğim bir örneğini buldum https://yadi.sk/d/r_ULA1rz3EoLcP
 
Umarım yanlış anlamadım.

Alt taraftan ARAMA SAYFASInın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ taraftaki kodların en altına aşağıdaki kod'u yapıştırın.
Kod'daki kırmızı satır, gizli olan GÖRÜŞ.TUTANAK adlı sayfayı görünür hale getirir.

B sütunundaki sayfa adına fareyle çift tıkladığınızda ilgili sayfaya gidilir.

İlave not: Kullanım kolaylığı bakımından;
her sayfaya, ARAMA SAYFASIna dönmenizi sağlayacak birer tani düğme eklemenizi öneriyorum.
.
Kod: 
[B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
[COLOR="Red"]If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True[/COLOR]
Sheets(Target.Value).Activate: Cancel = True
[B]End Sub[/B]
 
Ömer BARAN' Alıntı:
Umarım yanlış anlamadım.

Alt taraftan ARAMA SAYFASInın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ taraftaki kodların en altına aşağıdaki kod'u yapıştırın.
Kod'daki kırmızı satır, gizli olan GÖRÜŞ.TUTANAK adlı sayfayı görünür hale getirir.

B sütunundaki sayfa adına fareyle çift tıkladığınızda ilgili sayfaya gidilir.

İlave not: Kullanım kolaylığı bakımından;
her sayfaya, ARAMA SAYFASIna dönmenizi sağlayacak birer tani düğme eklemenizi öneriyorum.alakasnızıa
.
Kod: 
[B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
[COLOR="Red"]If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True[/COLOR]
Sheets(Target.Value).Activate: Cancel = True
[B]End Sub[/B]
Genişletmek için tıkla ...

Ömer bey alakanıza teşekkür ediyorum. Fakat bana yalnızca sayfaya yönlenmek değil satıra yönlenmek yardımcı olacaktır. Çünkü sayfaya yönlenince ilgilinin satırını bulmak için tekrar yüzlerce satırın arasından o ilgiliyi bulmam gerekecek. Bu sebeple, eğer mümkünse gelen arama sonuçlarından C sütunundaki bilgiyi tıkladığımda beni ilgili sayfada ilgili satıra götürmeli. Mesela, ali arama sonucunda alinin istanbul 16. idare Mh. bir dosyası olduğu listelendi. Ben C sütununda gelen arama sonucunu (Mahkeme adını) tıklarsam beni örnekteki gibi idare sayfasında ilgili satıra getirmeli..
 
Tekrar merhaba.

Mevcut kodlarınıza en az müdahale etmek için; aslında yaptığım şey,
sadece mavi renklendirdiğim kısımları eklemek oldu.

Uzun uzun anlatmak yerine silip yeni haliyle yapıştırmanızı önereceğim.

Alt taraftan ARAMA SAYFASI adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin.
Açılan VBA ekranında sağ taraftaki kodların tümünü silip, yerine aşağıdaki kodları yapıştırın.

ARAMA sayfası Q sütununu seçip yazıtipi rengini BEYAZ ayarlayın veya Q sütununu gizleyin.
(kodlar Q sütununa bulunan verinin ADRESini yazacak ve oradaki adres bilgisinden hareketle ilgili hücre seçilecek.)

ARAMA işlemi tamamlandığında B sütunundaki sayfa adına fareyle çift tıklamanız yeterli olacaktır.

.
Kod: 
[B]Private Sub ToggleButton1_Click()[/B]
    If ToggleButton1.Value = False Then
        soru = Application.InputBox("Bu sayfa şifrelidir.", "Uyarı!")
        If soru = "00hukuk1980" Then
            Sayfa11.Visible = xlSheetVisible
            ToggleButton1.Caption = "TUTANAKLARI GİZLE"
                Else
            MsgBox "Parola yanlış", vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
            Exit Sub
        End If
        Else
            Sayfa11.Visible = xlSheetVeryHidden
            ToggleButton1.Caption = "TUTANAKLARI GÖSTER"
    End If
[B]End Sub[/B]

[B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True
[COLOR="blue"]Sheets(Target.Value).Activate
Sheets(Target.Value).Range(Cells(Target.Row, 17).Value).Activate
Cancel = True[/COLOR]
End Sub

[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
    Dim syf As Worksheet, evn As Range
    If Target.Address(0, 0) = "A1" Then
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    Sayfa13.Range("B2:M1000").ClearContents
[COLOR="blue"]Sayfa13.Range("Q2:Q" & Sayfa13.Cells(Rows.Count, "Q").End(3).Row).ClearContents[/COLOR]
    For Each syf In ThisWorkbook.Worksheets
        If Sayfa13.CheckBox1.Value = False And syf.Name = "DURUŞMA LİSTESİ" Then GoTo 20
        If Sayfa13.CheckBox2.Value = False And syf.Name = "ARŞİV" Then GoTo 20
        If Sayfa13.CheckBox3.Value = False And syf.Name = "İCRA" Then GoTo 20
        If Sayfa13.CheckBox5.Value = False And syf.Name = "MÜVEKKİL TEL. REHBERİ" Then GoTo 20
        If syf.Name <> "ARAMA SAYFASI" Then
        Set evn = syf.Cells.Find(Target.Value & "*", , , 2, , , MatchCase:=False, SearchFormat:=False)
            If Not evn Is Nothing Then
                If syf.Cells(1, evn.Column).Value <> "DURUŞMA TARİHİ" Or syf.Cells(1, evn.Column).Value <> "YAPILACAKLAR" Then
                    ee = evn.Address
                    Do
                        Set evn = syf.Cells.FindNext(evn)
                        Sayfa13.Range("B65536").End(3)(2, 1) = syf.Name
[COLOR="blue"]brn = Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1[/COLOR]
                        syf.Range("A" & evn.Row & ":M" & evn.Row).Copy
                        Sayfa13.Range("C65536").End(3)(2, 1).PasteSpecial xlPasteValues
[COLOR="blue"]Sayfa13.Cells(brn, 17) = evn.Address(0, 0)[/COLOR]
                    Loop While Not evn Is Nothing And ee <> evn.Address
                End If

            End If
        End If
20    Next syf
    ActiveSheet.Range("$A$1:$J$17").RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
    For i = 2 To Range("B65536").End(3).Row
        If Cells(i, "F").Value = "" Then
            Cells(i, "F").Delete Shift:=xlToLeft
[COLOR="blue"]Cells(i, "O").Insert Shift:=xlToRight[/COLOR]
        End If
        If Cells(i, 2).Value = "İSTANBUL" And Cells(i, 5).Value = "" Then
            Range("F" & i & ":M" & i).Cut Destination:=Range("E" & i & ":L" & i)
[COLOR="blue"]Cells(i, "O").Insert Shift:=xlToRight[/COLOR]
        End If
    Next i
    
    Dim bul As Range
    Range("B2:J" & Range("B5536").End(3).Row).Font.ColorIndex = 1
    For Each bul In Range("B2:J" & Range("B5536").End(3).Row).SpecialCells(xlCellTypeConstants, 2)
      renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Do
            If renk > 0 Then
                bul.Characters(Start:=renk, Length:=Len(Target.Value)).Font.ColorIndex = 3
            End If
            renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Loop While renk > 0
    Next bul
    Range("E:F").NumberFormat = "dd.mm.yyyy"
    
    If Sayfa13.CheckBox4.Value = False Then
        For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) = "1)" Or Len(Cells(a, "G").Value) < 2 Then
                Cells(a, "G").Value = ""
                Cells(a, "G").Delete Shift:=xlToLeft
[COLOR="blue"]Cells(a, "O").Insert Shift:=xlToRight[/COLOR]
            End If
        Next a
       Range("G1").Value = "SON DURUM"
       Range("H1").Value = ""
       Else
       Range("G1").Copy Range("h1")
       Range("G1").Value = "DURUŞMA TARİHİ"
       Range("H1").Value = "SON DURUM"
       For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) <> "1)" And Len(Cells(a, "G").Value) > 2 Then
                Range("G" & a & ":I" & a).Cut Destination:=Range("H" & a & ":J" & a)
            End If
        Next a
    End If
30    Application.EnableEvents = True
    Target.Activate
    MsgBox "Arama Tamamlanmıştır", vbInformation + vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
    End If
[B]End Sub[/B]
 
Ömer BARAN' Alıntı:
Tekrar merhaba.

Mevcut kodlarınıza en az müdahale etmek için; aslında yaptığım şey,
sadece mavi renklendirdiğim kısımları eklemek oldu.

Uzun uzun anlatmak yerine silip yeni haliyle yapıştırmanızı önereceğim.

Alt taraftan ARAMA SAYFASI adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin.
Açılan VBA ekranında sağ taraftaki kodların tümünü silip, yerine aşağıdaki kodları yapıştırın.

ARAMA sayfası Q sütununu seçip yazıtipi rengini BEYAZ ayarlayın veya Q sütununu gizleyin.
(kodlar Q sütununa bulunan verinin ADRESini yazacak ve oradaki adres bilgisinden hareketle ilgili hücre seçilecek.)

ARAMA işlemi tamamlandığında B sütunundaki sayfa adına fareyle çift tıklamanız yeterli olacaktır.

.
Kod: 
[B]Private Sub ToggleButton1_Click()[/B]
    If ToggleButton1.Value = False Then
        soru = Application.InputBox("Bu sayfa şifrelidir.", "Uyarı!")
        If soru = "00hukuk1980" Then
            Sayfa11.Visible = xlSheetVisible
            ToggleButton1.Caption = "TUTANAKLARI GİZLE"
                Else
            MsgBox "Parola yanlış", vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
            Exit Sub
        End If
        Else
            Sayfa11.Visible = xlSheetVeryHidden
            ToggleButton1.Caption = "TUTANAKLARI GÖSTER"
    End If
[B]End Sub[/B]

[B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True
[COLOR="blue"]Sheets(Target.Value).Activate
Sheets(Target.Value).Range(Cells(Target.Row, 17).Value).Activate
Cancel = True[/COLOR]
End Sub

[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
    Dim syf As Worksheet, evn As Range
    If Target.Address(0, 0) = "A1" Then
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    Sayfa13.Range("B2:M1000").ClearContents
[COLOR="blue"]Sayfa13.Range("Q2:Q" & Sayfa13.Cells(Rows.Count, "Q").End(3).Row).ClearContents[/COLOR]
    For Each syf In ThisWorkbook.Worksheets
        If Sayfa13.CheckBox1.Value = False And syf.Name = "DURUŞMA LİSTESİ" Then GoTo 20
        If Sayfa13.CheckBox2.Value = False And syf.Name = "ARŞİV" Then GoTo 20
        If Sayfa13.CheckBox3.Value = False And syf.Name = "İCRA" Then GoTo 20
        If Sayfa13.CheckBox5.Value = False And syf.Name = "MÜVEKKİL TEL. REHBERİ" Then GoTo 20
        If syf.Name <> "ARAMA SAYFASI" Then
        Set evn = syf.Cells.Find(Target.Value & "*", , , 2, , , MatchCase:=False, SearchFormat:=False)
            If Not evn Is Nothing Then
                If syf.Cells(1, evn.Column).Value <> "DURUŞMA TARİHİ" Or syf.Cells(1, evn.Column).Value <> "YAPILACAKLAR" Then
                    ee = evn.Address
                    Do
                        Set evn = syf.Cells.FindNext(evn)
                        Sayfa13.Range("B65536").End(3)(2, 1) = syf.Name
[COLOR="blue"]brn = Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1[/COLOR]
                        syf.Range("A" & evn.Row & ":M" & evn.Row).Copy
                        Sayfa13.Range("C65536").End(3)(2, 1).PasteSpecial xlPasteValues
[COLOR="blue"]Sayfa13.Cells(brn, 17) = evn.Address(0, 0)[/COLOR]
                    Loop While Not evn Is Nothing And ee <> evn.Address
                End If

            End If
        End If
20    Next syf
    ActiveSheet.Range("$A$1:$J$17").RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
    For i = 2 To Range("B65536").End(3).Row
        If Cells(i, "F").Value = "" Then
            Cells(i, "F").Delete Shift:=xlToLeft
[COLOR="blue"]Cells(i, "O").Insert Shift:=xlToRight[/COLOR]
        End If
        If Cells(i, 2).Value = "İSTANBUL" And Cells(i, 5).Value = "" Then
            Range("F" & i & ":M" & i).Cut Destination:=Range("E" & i & ":L" & i)
[COLOR="blue"]Cells(i, "O").Insert Shift:=xlToRight[/COLOR]
        End If
    Next i
    
    Dim bul As Range
    Range("B2:J" & Range("B5536").End(3).Row).Font.ColorIndex = 1
    For Each bul In Range("B2:J" & Range("B5536").End(3).Row).SpecialCells(xlCellTypeConstants, 2)
      renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Do
            If renk > 0 Then
                bul.Characters(Start:=renk, Length:=Len(Target.Value)).Font.ColorIndex = 3
            End If
            renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Loop While renk > 0
    Next bul
    Range("E:F").NumberFormat = "dd.mm.yyyy"
    
    If Sayfa13.CheckBox4.Value = False Then
        For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) = "1)" Or Len(Cells(a, "G").Value) < 2 Then
                Cells(a, "G").Value = ""
                Cells(a, "G").Delete Shift:=xlToLeft
[COLOR="blue"]Cells(a, "O").Insert Shift:=xlToRight[/COLOR]
            End If
        Next a
       Range("G1").Value = "SON DURUM"
       Range("H1").Value = ""
       Else
       Range("G1").Copy Range("h1")
       Range("G1").Value = "DURUŞMA TARİHİ"
       Range("H1").Value = "SON DURUM"
       For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) <> "1)" And Len(Cells(a, "G").Value) > 2 Then
                Range("G" & a & ":I" & a).Cut Destination:=Range("H" & a & ":J" & a)
            End If
        Next a
    End If
30    Application.EnableEvents = True
    Target.Activate
    MsgBox "Arama Tamamlanmıştır", vbInformation + vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
    End If
[B]End Sub[/B]
Genişletmek için tıkla ...
Merhaba, Elinize sağlık fakat bazı arama sonuçlarında çift tıkladığımda "Run Time Error 1004" hatası verip "Sheets(Target.Value).Range(Cells(Target.Row, 17).Value).Activate" satırını sarı yapıyor.
 
Ben örnek belgenizde bir hata almadım.
Örnek arama kriteri ve bu kritere uyan sayfa adı ve veriyi belirtirseniz, aynı adrese yazıp, aynı kriterle arama yaptırayım.
 
Ömer bey,
Şunan o bilgisayarda değilim. Dışarıdayım. Yarın öğleden sonra detaylı yazayım . İyi geceler.
 
Tekrar merhaba.
ARAMA SAYFASInın kodlarının tümünü aşağıdakiyle değiştirin.
.
Kod: 
[B]Private Sub ToggleButton1_Click()[/B]
    If ToggleButton1.Value = False Then
        soru = Application.InputBox("Bu sayfa şifrelidir.", "Uyarı!")
        If soru = "00hukuk1980" Then
            Sayfa11.Visible = xlSheetVisible
            ToggleButton1.Caption = "TUTANAKLARI GİZLE"
                Else
            MsgBox "Parola yanlış", vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
            Exit Sub
        End If
        Else
            Sayfa11.Visible = xlSheetVeryHidden
            ToggleButton1.Caption = "TUTANAKLARI GÖSTER"
    End If
[B]End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True
[R1] = Target.Address(0, 0)
Sheets(Target.Value).Activate
Sheets(Target.Value).Range(Cells(Target.Row, 17).Value).Activate
Cancel = True
[B]End Sub

Private Sub Worksheet_Change(ByVal Target As Range)[/B]
    Dim syf As Worksheet, evn As Range
    If Target.Address(0, 0) = "A1" Then
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    Sayfa13.Range("B2:M1000").ClearContents
Sayfa13.Columns("P:Q").ClearContents
Sayfa13.[Q1] = "ADRES": Sayfa13.[R1] = ""
Sayfa13.Range("B2:K" & Rows.Count).Borders.LineStyle = xlNone
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    For Each syf In ThisWorkbook.Worksheets
        If Sayfa13.CheckBox1.Value = False And syf.Name = "DURUŞMA LİSTESİ" Then GoTo 20
        If Sayfa13.CheckBox2.Value = False And syf.Name = "ARŞİV" Then GoTo 20
        If Sayfa13.CheckBox3.Value = False And syf.Name = "İCRA" Then GoTo 20
        If syf.Name <> "ARAMA SAYFASI" Then
        Set evn = syf.Cells.Find(Target.Value & "*", , , 2, , , MatchCase:=False, SearchFormat:=False)
            If Not evn Is Nothing Then
                If syf.Cells(1, evn.Column).Value <> "DURUŞMA TARİHİ" Or syf.Cells(1, evn.Column).Value <> "YAPILACAKLAR" Then
                    ee = evn.Address
                    Do
                        Set evn = syf.Cells.FindNext(evn)
                        Sayfa13.Range("B65536").End(3)(2, 1) = syf.Name
                        
                        syf.Range("A" & evn.Row & ":M" & evn.Row).Copy
                        Sayfa13.Range("C65536").End(3)(2, 1).PasteSpecial xlPasteValues
satt = Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1
Sayfa13.Cells(Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1, 17) = evn.Address(0, 0) 'Range(ee).Address(0, 0) 'evn.Address(0, 0)
                    Loop While Not evn Is Nothing And ee <> evn.Address
                End If
            End If
        End If
20    Next syf
    ActiveSheet.Range("A1:Q" & Sayfa13.Cells(Rows.Count, "B").End(3).Row).RemoveDuplicates Columns:=Array(1, 2, 3, _
                                        4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlYes
    For i = 2 To Range("B65536").End(3).Row
        If Cells(i, "F").Value = "" Then
            Cells(i, "F").Delete Shift:=xlToLeft
Cells(i, "O").Insert Shift:=xlToRight
        End If
        If Cells(i, 2).Value = "İSTANBUL" And Cells(i, 5).Value = "" Then
            Range("F" & i & ":M" & i).Copy Destination:=Range("E" & i & ":L" & i)
            Cells(i, "M").ClearContents
        End If
    Next i
    
    Dim bul As Range
    Range("B2:J" & Range("B5536").End(3).Row).Font.ColorIndex = 1
    For Each bul In Range("B2:J" & Range("B5536").End(3).Row).SpecialCells(xlCellTypeConstants, 2)
      renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Do
            If renk > 0 Then
                bul.Characters(Start:=renk, Length:=Len(Target.Value)).Font.ColorIndex = 3
            End If
            renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Loop While renk > 0
    Next bul
    Range("E:F").NumberFormat = "dd.mm.yyyy"
    
    If Sayfa13.CheckBox4.Value = False Then
        For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) = "1)" Or Len(Cells(a, "G").Value) < 2 Then
                Cells(a, "G").Value = ""
                Cells(a, "G").Delete Shift:=xlToLeft
Cells(a, "O").Insert Shift:=xlToRight
            End If
        Next a
       Range("G1").Value = "SON DURUM"
       Range("H1").Value = ""
       Else
       Range("G1").Copy Range("h1")
       Range("G1").Value = "DURUŞMA TARİHİ"
       Range("H1").Value = "SON DURUM"
       For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) <> "1)" And Len(Cells(a, "G").Value) > 2 Then
                Range("G" & a & ":I" & a).Copy Destination:=Range("H" & a & ":J" & a)
                Cells(a, "G").ClearContents
            End If
        Next a
    End If
30    Application.EnableEvents = True
Range("B" & Cells(Rows.Count, 2).End(3).Row + 1 & ":Q" & Rows.Count).ClearContents
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Font.Size = 8
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).WrapText = True
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).HorizontalAlignment = xlLeft
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).VerticalAlignment = xlCenter
    
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Borders.LineStyle = xlContinuous
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Borders.Weight = xlHairline
Rows.AutoFit
ActiveWindow.SmallScroll Down:=-1000
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
adet = Cells(Rows.Count, 17).End(3).Row - 1
    Target.Activate
    MsgBox "Arama işlemi tamamlandı." & vbLf & "Bulunan kayıt sayısı :  " & adet, vbInformation + vbMsgBoxRtlReading, "..::.. Ö. BARAN ..::.."
    End If
[B]End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/B]
Range("B2:K" & Rows.Count).Interior.Color = xlNone
On Error Resume Next
    If Target.Column > 1 And Target.Column < 10 And Target.Row > 1 And Cells(Target.Row, 2) <> "" Then
        Range("B" & Target.Row & ":I" & Target.Row).Interior.ColorIndex = 15
    End If
End Sub
 
Ömer BARAN' Alıntı:
Tekrar merhaba.
ARAMA SAYFASInın kodlarının tümünü aşağıdakiyle değiştirin.
.
Kod: 
[B]Private Sub ToggleButton1_Click()[/B]
    If ToggleButton1.Value = False Then
        soru = Application.InputBox("Bu sayfa şifrelidir.", "Uyarı!")
        If soru = "00hukuk1980" Then
            Sayfa11.Visible = xlSheetVisible
            ToggleButton1.Caption = "TUTANAKLARI GİZLE"
                Else
            MsgBox "Parola yanlış", vbMsgBoxRtlReading, "Www.ExcelArsivi.Com"
            Exit Sub
        End If
        Else
            Sayfa11.Visible = xlSheetVeryHidden
            ToggleButton1.Caption = "TUTANAKLARI GÖSTER"
    End If
[B]End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)[/B]
If Intersect(Target, Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)) Is Nothing Then Exit Sub
If Target.Value = "GÖRÜŞ.TUTANAK" Then Sheets(Target.Value).Visible = True
[R1] = Target.Address(0, 0)
Sheets(Target.Value).Activate
Sheets(Target.Value).Range(Cells(Target.Row, 17).Value).Activate
Cancel = True
[B]End Sub

Private Sub Worksheet_Change(ByVal Target As Range)[/B]
    Dim syf As Worksheet, evn As Range
    If Target.Address(0, 0) = "A1" Then
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    Sayfa13.Range("B2:M1000").ClearContents
Sayfa13.Columns("P:Q").ClearContents
Sayfa13.[Q1] = "ADRES": Sayfa13.[R1] = ""
Sayfa13.Range("B2:K" & Rows.Count).Borders.LineStyle = xlNone
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    For Each syf In ThisWorkbook.Worksheets
        If Sayfa13.CheckBox1.Value = False And syf.Name = "DURUŞMA LİSTESİ" Then GoTo 20
        If Sayfa13.CheckBox2.Value = False And syf.Name = "ARŞİV" Then GoTo 20
        If Sayfa13.CheckBox3.Value = False And syf.Name = "İCRA" Then GoTo 20
        If syf.Name <> "ARAMA SAYFASI" Then
        Set evn = syf.Cells.Find(Target.Value & "*", , , 2, , , MatchCase:=False, SearchFormat:=False)
            If Not evn Is Nothing Then
                If syf.Cells(1, evn.Column).Value <> "DURUŞMA TARİHİ" Or syf.Cells(1, evn.Column).Value <> "YAPILACAKLAR" Then
                    ee = evn.Address
                    Do
                        Set evn = syf.Cells.FindNext(evn)
                        Sayfa13.Range("B65536").End(3)(2, 1) = syf.Name
                        
                        syf.Range("A" & evn.Row & ":M" & evn.Row).Copy
                        Sayfa13.Range("C65536").End(3)(2, 1).PasteSpecial xlPasteValues
satt = Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1
Sayfa13.Cells(Sayfa13.Cells(Rows.Count, "Q").End(3).Row + 1, 17) = evn.Address(0, 0) 'Range(ee).Address(0, 0) 'evn.Address(0, 0)
                    Loop While Not evn Is Nothing And ee <> evn.Address
                End If
            End If
        End If
20    Next syf
    ActiveSheet.Range("A1:Q" & Sayfa13.Cells(Rows.Count, "B").End(3).Row).RemoveDuplicates Columns:=Array(1, 2, 3, _
                                        4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlYes
    For i = 2 To Range("B65536").End(3).Row
        If Cells(i, "F").Value = "" Then
            Cells(i, "F").Delete Shift:=xlToLeft
Cells(i, "O").Insert Shift:=xlToRight
        End If
        If Cells(i, 2).Value = "İSTANBUL" And Cells(i, 5).Value = "" Then
            Range("F" & i & ":M" & i).Copy Destination:=Range("E" & i & ":L" & i)
            Cells(i, "M").ClearContents
        End If
    Next i
    
    Dim bul As Range
    Range("B2:J" & Range("B5536").End(3).Row).Font.ColorIndex = 1
    For Each bul In Range("B2:J" & Range("B5536").End(3).Row).SpecialCells(xlCellTypeConstants, 2)
      renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Do
            If renk > 0 Then
                bul.Characters(Start:=renk, Length:=Len(Target.Value)).Font.ColorIndex = 3
            End If
            renk = InStr(renk + 1, LCase(Replace(bul.Text, "İ", "i")), Target.Value)
        Loop While renk > 0
    Next bul
    Range("E:F").NumberFormat = "dd.mm.yyyy"
    
    If Sayfa13.CheckBox4.Value = False Then
        For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) = "1)" Or Len(Cells(a, "G").Value) < 2 Then
                Cells(a, "G").Value = ""
                Cells(a, "G").Delete Shift:=xlToLeft
Cells(a, "O").Insert Shift:=xlToRight
            End If
        Next a
       Range("G1").Value = "SON DURUM"
       Range("H1").Value = ""
       Else
       Range("G1").Copy Range("h1")
       Range("G1").Value = "DURUŞMA TARİHİ"
       Range("H1").Value = "SON DURUM"
       For a = 2 To Range("B65536").End(3).Row
            If Left(Cells(a, "G").Value, 2) <> "1)" And Len(Cells(a, "G").Value) > 2 Then
                Range("G" & a & ":I" & a).Copy Destination:=Range("H" & a & ":J" & a)
                Cells(a, "G").ClearContents
            End If
        Next a
    End If
30    Application.EnableEvents = True
Range("B" & Cells(Rows.Count, 2).End(3).Row + 1 & ":Q" & Rows.Count).ClearContents
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Font.Size = 8
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).WrapText = True
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).HorizontalAlignment = xlLeft
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).VerticalAlignment = xlCenter
    
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Borders.LineStyle = xlContinuous
Range("B2:K" & Cells(Rows.Count, 2).End(3).Row).Borders.Weight = xlHairline
Rows.AutoFit
ActiveWindow.SmallScroll Down:=-1000
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
adet = Cells(Rows.Count, 17).End(3).Row - 1
    Target.Activate
    MsgBox "Arama işlemi tamamlandı." & vbLf & "Bulunan kayıt sayısı :  " & adet, vbInformation + vbMsgBoxRtlReading, "..::.. Ö. BARAN ..::.."
    End If
[B]End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/B]
Range("B2:K" & Rows.Count).Interior.Color = xlNone
On Error Resume Next
    If Target.Column > 1 And Target.Column < 10 And Target.Row > 1 And Cells(Target.Row, 2) <> "" Then
        Range("B" & Target.Row & ":I" & Target.Row).Interior.ColorIndex = 15
    End If
End Sub
Genişletmek için tıkla ...

Merhaba, Tam ihtiyaca göre olmuş. Bütün çaba ve yardımınız için teşekkür ediyorum. İşleriniz yolunda gitsin..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst