• DİKKAT

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

makro ile köprü

P

peleryn

Katılım
10 Mayıs 2009
Mesajlar
1,080
Excel Vers. ve Dili
2003 türkçe
Herkese merhabalar;

Sorum sağ klik menüsünden hücreler arasında kurabildiğimiz köprüyü belirlenmiş iki sayfadaki iki aralıkta bulunan ortak değerler arasında makro ile kurmakla ilgili.

Gerekli açıklamayı ve hazırlığı örnek dosyada yaptım.

İlgilenecek olanlara şimdiden teşekkür ederim.
 

Ekli dosyalar

Merhaba,

Köprüsüz çözüm ister misiniz?

İlgili Sayfalardaki ilgili alanlardaki ilgili hücreye çift tıklamanız yeterli.

Sayfa1 Kod:

Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [B2:D13]) Is Nothing Then Exit Sub
Dim c As Range
If Target.Value = "" Then Exit Sub
Set c = Sheets("Sayfa2").Range("B2:D13").Find(Target.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not c Is Nothing Then
    Sheets("Sayfa2").Select
    c.Select
End If
End Sub

Sayfa2 Kod :

Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [B2:D13]) Is Nothing Then Exit Sub
Dim c As Range
If Target.Value = "" Then Exit Sub
Set c = Sheets("Sayfa1").Range("B2:D13").Find(Target.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not c Is Nothing Then
    Sheets("Sayfa1").Select
    c.Select
End If
End Sub
 

Ekli dosyalar

Necdet hocam elinize sağlık çok güzel olmuş fakat kullanım açısından şöyle birşeye ihtiyacım var:Eğitim amaçlı flash kartları bilirsiniz ön yüzünde soru arka yüzünde cevap vardır.Buna benzer tarzda bir çalışma yapacağım.Diyelim ki ingilizce kelimeler ve karşılıkları için olsun..Önce belirlenmiş alanlara randomla benzer değerleri dağıtıp aralarında köprüleri kurdurtacağım daha sonra sayfalardan birindeki değerleri diğerinin karşılığı olarak değiştireceğim.Mesela Sayfa1 de mavi Sayfa2 de blue olarak.İşte köprü bunun için lazım.Değeri değiştirdiğimde köprü bozulmaz,randomla dağıttığımda yerini ezberleme sorunu ortadan kalkar vs..
 
Necdet hocam çok güzel bir alternatif hazırlamış ama neden köprü konusunda ısrar ettiğimi umarım anlatabilmişimdir.Aynı değerler sadece başlangıçta hangi hücreler arasında karşılıklı bağlantı kurulacağının belirlenmesi için kullanılacak ve daha sonra değerlerden birisi diğerinin karşılığı/yanıtı olacak şekilde değiştirilecek.İşte bu değiştirme işlemi yapıldığında köprüler kalıcı olabilir ve bana lazım olan da bu..

Umarım bir ilgilenen vardır herkese iyi çalışmalar dilerim.
 
Belki dosyayla bir ilgilenen vardır diye bir iki gün bekledim ama sanırım bu soruma bir çözüm bulamayacağım.Bu durumda Necdet hocamın önerdiği alternatiften hareketle (hatta benim ilk tasarladığımdan daha işlevsel bir şekilde) yeni bir dosya düzenledim.

Böylece soru:İki sütundaki değerlerin random'la kendilerine ait tablolara dağıtılmaları (tercihen bir buton yardımıyla) ve dağıtılan değerler arasında karşılıklı select ilişkisinin kurulması ile ilgili bir soruya dönüştü.

İlgilenecek olan herkese şimdiden çok teşekkür ederim.
 

Ekli dosyalar

Dosyanız ektedir.:cool:
Kod: 
Sub rastgele()
Randomize Timer
Dim hcr As Range, sat As Byte, i As Byte, sat2 As Byte
Dim col As Collection
Set col = New Collection
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("F6:L15").ClearContents
sat2 = 2
For Each hcr In Range("F6:H15")
    col.Add hcr.Address
Next
Do While col.Count >= 1
    sat = CInt(Int(Rnd() * col.Count) + 1)
    Range(col(sat)).Value = Cells(sat2, "B").Value
    sat2 = sat2 + 1
    col.Remove (sat)
Loop
sat2 = 2
For Each hcr In Range("J6:L15")
    col.Add hcr.Address
Next
Do While col.Count >= 1
    sat = CInt(Int(Rnd() * col.Count) + 1)
    Range(col(sat)).Value = Cells(sat2, "C").Value
    sat2 = sat2 + 1
    col.Remove (sat)
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim k As Range, c As Range
If Intersect(Target, [F6:H15,J6:L15]) Is Nothing Then Exit Sub
If Target.Column < 10 Then
    Set k = Range("B2:B31").Find(Target.Value, , xlValues, xlWhole)
    If k Is Nothing Then Exit Sub
    Set c = Range("J6:L15").Find(k.Offset(0, 1).Value, , xlValues, xlWhole)
    If Not c Is Nothing Then c.Select
    Else
    Set k = Range("C2:C31").Find(Target.Value, , xlValues, xlWhole)
    If k Is Nothing Then Exit Sub
    Set c = Range("F6:H15").Find(k.Offset(0, -1).Value, , xlValues, xlWhole)
    If Not c Is Nothing Then c.Select
End If
End Sub
 

Ekli dosyalar

peleryn' Alıntı:
Herkese merhabalar;

Sorum sağ klik menüsünden hücreler arasında kurabildiğimiz köprüyü belirlenmiş iki sayfadaki iki aralıkta bulunan ortak değerler arasında makro ile kurmakla ilgili.

Gerekli açıklamayı ve hazırlığı örnek dosyada yaptım.

İlgilenecek olanlara şimdiden teşekkür ederim.
Genişletmek için tıkla ...

bu kodu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()
For r = 2 To 4
For i = 2 To 13
bul = Cells(i, r).Value
If bul <> "" Then
Set d = Worksheets("Sayfa2").Range("B2:D13").Find(bul, LookAt:=xlWhole)
If Not d Is Nothing Then
firstAddress = d.Address
Do
On Error Resume Next
Cells(i, r).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="Sayfa2!" & firstAddress ', TextToDisplay:=bul
Set d = Worksheets("Sayfa2").Cells.FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstAddress
End If
End If
Next i
Next r
End Sub
 
Evren hocam ellerinize sağlık harika oldu sayenizde çocuklarla yapacağım çalışmalarda kullanacağım zevkli bir programcık hazırlanmış oldu..

Halit hocam heralde yanıt çıkmaz derken çok güzel bir çözüm sunmuşsunuz elinize sağlık yalnız buton sadece sayfa1 deki değerlere köprü kuruyor sayfa2 de de bunun karşılığı olan köprüleri kurması lazım.Tek butonda yapabilir miyim bilmiyorum ama en azından 2. bir butonu sayfa 2 ye koyduğumda kurabilecekmişim gibi görünüyor.Vaktim olunca ayrıntılı bakacağım..

Hocalarıma tekrar çok teşekkür ediyorum.
 
Halit hocam kodları ikinci bir butonla iki tabloyu da şekillendirecek hale getirdim teşekkür ederim.
 
peleryn' Alıntı:
Evren hocam ellerinize sağlık harika oldu sayenizde çocuklarla yapacağım çalışmalarda kullanacağım zevkli bir programcık hazırlanmış oldu..

Halit hocam heralde yanıt çıkmaz derken çok güzel bir çözüm sunmuşsunuz elinize sağlık yalnız buton sadece sayfa1 deki değerlere köprü kuruyor sayfa2 de de bunun karşılığı olan köprüleri kurması lazım.Tek butonda yapabilir miyim bilmiyorum ama en azından 2. bir butonu sayfa 2 ye koyduğumda kurabilecekmişim gibi görünüyor.Vaktim olunca ayrıntılı bakacağım..

Hocalarıma tekrar çok teşekkür ediyorum.
Genişletmek için tıkla ...


birde bu kodu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()
For r = 2 To 4
For i = 2 To 13
bul = Worksheets("Sayfa1").Cells(i, r).Value
If bul <> "" Then
Set d = Worksheets("Sayfa2").Range("B2:D13").Find(bul, LookAt:=xlWhole)
If Not d Is Nothing Then
firstAddress = d.Address
Do
On Error Resume Next
Worksheets("Sayfa1").Cells(i, r).Hyperlinks.Add Anchor:=Worksheets("Sayfa1").Cells(i, r), Address:="", SubAddress:="Sayfa2!" & firstAddress ', TextToDisplay:=bul
Worksheets("Sayfa2").Range(d.Address).Hyperlinks.Add Anchor:=Worksheets("Sayfa2").Range(d.Address), Address:="", SubAddress:="Sayfa1!" & Worksheets("Sayfa1").Cells(i, r).Address
Set d = Worksheets("Sayfa2").Cells.FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstAddress
End If
End If
Next i
Next r
End Sub
 
Halit hocam ellerinize sağlık konuyu açarken sorduğum sorunun net cevabı bu..

Bu konudaki yardımlarınız için size,Evren ve Necdet hocama tekrar teşekkür ederim.
 
Evren Hocam ;

Dosyanızdaki dblclick kodlarına bir iki eklemeyle TABLO A da bir değer tıklandığında target ve Tablo B deki karşılığının biçimlenmesini sağlayabildim ama TABLO B ye tıkladığımda aynı işlemi yapmasını sağlayamadım.Yardımcı olursanız sevinirim.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Worksheets("Sayfa1").Cells.Interior.ColorIndex = xlNone
Worksheets("Sayfa1").Cells.Font.Size = 8
Dim k As Range, c As Range
If Intersect(Target, [F6:H15,J6:L15]) Is Nothing Then Exit Sub
If Target.Column < 10 Then
Set k = Range("B2:B31").Find(Target.Value, , xlValues, xlWhole)
If k Is Nothing Then Exit Sub
Target.Interior.ColorIndex = 8
Target.Font.Size = 20
Set c = Range("J6:L15").Find(k.Offset(0, 1).Value, , xlValues, xlWhole)
If Not c Is Nothing Then c.Select
c.Interior.ColorIndex = 8
c.Font.Size = 20
Else
Set k = Range("C2:C31").Find(Target.Value, , xlValues, xlWhole)
If k Is Nothing Then Exit Sub
Set c = Range("F6:H15").Find(k.Offset(0, -1).Value, , xlValues, xlWhole)
If Not c Is Nothing Then c.Select
End If
End Sub
Genişletmek için tıkla ...
 

Ekli dosyalar

peleryn' Alıntı:
Evren Hocam ;

Dosyanızdaki dblclick kodlarına bir iki eklemeyle TABLO A da bir değer tıklandığında target ve Tablo B deki karşılığının biçimlenmesini sağlayabildim ama TABLO B ye tıkladığımda aynı işlemi yapmasını sağlayamadım.Yardımcı olursanız sevinirim.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim k As Range, c As Range
If Intersect(Target, [F6:H15,J6:L15]) Is Nothing Then Exit Sub
Range("F6:H15,J6:L15").Interior.ColorIndex = xlNone
Range("F6:H15,J6:L15").Cells.Font.Size = 8

If Target.Column < 10 Then
Set k = Range("B2:B31").Find(Target.Value, , xlValues, xlWhole)
If k Is Nothing Then Exit Sub
Target.Interior.ColorIndex = 8
Target.Font.Size = 20
Set c = Range("J6:L15").Find(k.Offset(0, 1).Value, , xlValues, xlWhole)
If Not c Is Nothing Then
    c.Select
    c.Interior.ColorIndex = 8
    c.Font.Size = 20
End If
Else
Set k = Range("C2:C31").Find(Target.Value, , xlValues, xlWhole)
If k Is Nothing Then Exit Sub
Target.Interior.ColorIndex = 35
Target.Font.Size = 20
Set c = Range("F6:H15").Find(k.Offset(0, -1).Value, , xlValues, xlWhole)
If Not c Is Nothing Then
    c.Select
    c.Select
    c.Interior.ColorIndex = 35
    c.Font.Size = 20
End If
End If
End Sub
 

Ekli dosyalar

Sn Evren Gonzales diyesim geldi:)

Hızlı ilginiz ve çözümünüz için çok teşekkür ederim hocam.

Dosyayla ilgilenenlere şu anki verilerle:Satır yüksekliği 24 Sütun genişliği 12 değerleri ile incelemelerini öneririm.
 
Evren Hocam bu dosyayla ilgili son bir ricam daha var sizden..Varsayalım B sütunundaki 1 den fazla A değeri için C sütununda 1 den fazla değer tanımlanmış olsun.A değerleri görünürde aynı olduğu için şu an böyle birşey yaptığımda dblclick ile sürekli her A için tek bir hücreyi seçiyor.B sütunundaki her A değeri için bir multiselect tanımlayıp Tablo B de A değerine karşılık gelen değerlerin tümünü aynı anda seçebilir miyiz?

Bu durumda tabi Tablo B de bu değerlerden birisine tıkladığımızda ne olacak sorusu var.Bu işlem yapıldığında İster Tablo A daki tek bir A değerini seçer ister hepsini hangisini yapmak sizin için kolaysa uygundur hocam.
 
Son düzenleme:
peleryn' Alıntı:
Evren Hocam bu dosyayla ilgili son bir ricam daha var sizden..Varsayalım B sütunundaki 1 den fazla A değeri için C sütununda 1 den fazla değer tanımlanmış olsun.A değerleri görünürde aynı olduğu için şu an böyle birşey yaptığımda dblclick ile sürekli her A için tek bir hücreyi seçiyor.B sütunundaki her A değeri için bir multiselect tanımlayıp Tablo B de A değerine karşılık gelen değerlerin tümünü aynı anda seçebilir miyiz?

Bu durumda tabi Tablo B de bu değerlerden birisine tıkladığımızda ne olacak sorusu var.Bu işlem yapıldığında İster Tablo A daki tek bir A değerini seçer ister hepsini hangisini yapmak sizin için kolaysa uygundur hocam.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim c As Range, i As Byte, adr As String
If Intersect(Target, [F6:H15,J6:L15]) Is Nothing Then Exit Sub
Range("F6:H15,J6:L15").Interior.ColorIndex = xlNone
Range("F6:H15,J6:L15").Cells.Font.Size = 8

If Target.Column < 10 Then
    Target.Interior.ColorIndex = 8
    Target.Font.Size = 20
For i = 2 To 31
    If Cells(i, "B").Value = Target.Value Then
    Set c = Range("J6:L15").Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not c Is Nothing Then
        adr = c.Address
        Do
            c.Interior.ColorIndex = 8
            c.Font.Size = 20
            Set c = Range("J6:L15").FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adr
        c.Select
    End If
    End If
Next i
Else
Set k = Range("C2:C31").Find(Target.Value, , xlValues, xlWhole)
If k Is Nothing Then Exit Sub
Target.Interior.ColorIndex = 35
Target.Font.Size = 20
Set c = Range("F6:H15").Find(k.Offset(0, -1).Value, , xlValues, xlWhole)
If Not c Is Nothing Then
    c.Select
    c.Select
    c.Interior.ColorIndex = 35
    c.Font.Size = 20
End If
End If
End Sub
 

Ekli dosyalar

Evren Hocam ellerinize sağlık benim en sabırlı en bitane hocamsınız çok teşekkür ederim:)
 
peleryn' Alıntı:
Halit hocam kodları ikinci bir butonla iki tabloyu da şekillendirecek hale getirdim teşekkür ederim.
Genişletmek için tıkla ...


koddun hızlı çalışması için bazı düzenlemeler yaptım

Kod: 
Private Sub CommandButton1_Click()
Worksheets("Sayfa1").Range("B2:D13").Hyperlinks.Delete
Worksheets("Sayfa2").Range("B2:D13").Hyperlinks.Delete
For Each c In Worksheets("Sayfa1").Range("B2:D13")
If c.Value <> "" Then
bul = c.Value
If bul <> "" Then
Set d = Worksheets("Sayfa2").Range("B2:D13").Find(bul, LookAt:=xlWhole)
If Not d Is Nothing Then
firstAddress = d.Address
Do
On Error Resume Next
Worksheets("Sayfa1").Range(c.Address).Hyperlinks.Add Anchor:=Worksheets("Sayfa1").Range(c.Address), Address:="", SubAddress:="Sayfa2!" & firstAddress
Worksheets("Sayfa2").Range(d.Address).Hyperlinks.Add Anchor:=Worksheets("Sayfa2").Range(d.Address), Address:="", SubAddress:="Sayfa1!" & Worksheets("Sayfa1").Range(c.Address).Address
Set d = Worksheets("Sayfa2").Cells.FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstAddress
End If
End If
End If
Next c
End Sub
 
Halit hocam ellerinize sağlık cevap bulamayabilirim diye düşündüğüm bir konuda çok net ve güzel bir cevap hazırladınız.
Dosyanın son haliyle ilgilenecek olanlar olursa diye ekliyorum.

Tekrar çok teşekkür ediyorum hocam..
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst