• DİKKAT

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

Filtrelediğim verileri diğer sayfaya aktarma

T

thafha@hotmail.com

Katılım
13 Ekim 2008
Mesajlar
9
Excel Vers. ve Dili
11
Türkçe
Merhaba Sevgili Dostlar, Üstadlar.

Benim sıkıntım aşağıdaki dosyada filtrelediğim verileri diğer sayfaya aktarmak istiyorum.
(Olamasını istediğim sayfalar Bay/Bayan Kumite burada yaş ve kilo katogorilerini filtreliyorum ve bu filtrelenmiş bilgilerin kategori sayfasına aktarılmasını istiyorum. Aynı şekilde diğer sayfalarıda bu şekilde yapmalıyım.)
İlginize şimdiden teşekkür ederim.

EŞLEŞME PROGRAMI.xls - 986 KB
 
Dosyanız inmiyor başka bir dosya paylaşım sitesini kullanmayı deneyin. Konu karate ise ben de yakından ilgileniyorum.
 
Oğlum 5 senedir karate yapıyor ve camiadan birçok kişiyi tanırım.
 
Hocam öncelikle sorunuzu yanıtlayalım.
-Bay ve Bayan Kumite sayfalarının kod kısımlarına aşağıdaki kodları ayrı ayrı ekleyin.
-Sayfa içinde iken Geliştirici sekmesinde Ekle menüsü içinden Activex denetimlerinden bir komut düğmesi ekleyin.
Gelelim karateye. Hocam, biz İstanbul bölgesindeyiz. Bu spora Turhan Kaptan hocamız ile başladık, ama yaklaşık 5 senedir Çetin Demirel hocamızın öğrencisiyiz. Bunların yanında Haydar Güner ve Feray Koçali hocalarımızın derslerine de katılmaktayız. Yine bulunduğumuz okuldan dolayı Okay Arpa hocamızın derslerine de katılmaya çalışıyoruz.
İnşAllah bir ortamda görüşme fırsatı buluruz.

Kod: 
Private Sub CommandButton1_Click()
'Bay kumite sayfasına eklenecek
    Sheets("KATEGORİ ").Select
    Sheets("KATEGORİ ").[c4:c1000].ClearContents
    Sheets("BAY KUMİTE").[d4:d1000].Copy Sheets("KATEGORİ ").[c6]
End Sub
Private Sub CommandButton1_Click()
'Bayan kumite sayfasına eklenecek
    Sheets("KATEGORİ ").Select
    Sheets("KATEGORİ ").[c4:c1000].ClearContents
    Sheets("BAYAN KUMİTE").[d4:d1000].Copy Sheets("KATEGORİ ").[c6]
End Sub
 
Teşekkür ederim üstad sorunsuz çalıştı. Oğlunuza başarılar dilerim, Saydığınız isimlerin hepsi birbirinden değerli hocalarımızdır. Sevgi ve saygılarımla.
 
Hocam, eşleştirme sayfalarındaki birleştirilmiş hücreleri çözün yoksa kod doğru çalışmaz. Bir de Deneme isimli bir sayfa oluşturun.
Ayrıca kulubünüzü ve isminizi öğrenebilir miyim ? Müsabakalarda görüşme imkanımız olabilir belki. Bu bilgileri, özel mesaj şeklinde de gönderebilirsiniz.

Kod: 
Sub RasgeleSporcu()
'Sadece bu kodu çalıştırın.
    c = 2
    x = InputBox("Kaçlı Eşleme Yapmak İstiyor Sunuz ?", , 8)
    With Sheets("Deneme")
    .[a2:b100].Clear
    For i = 1 To 32
10
        Randomize

        a = Int((32 * Rnd) + 1)
        If WorksheetFunction.CountIf(.[a:b], a) = 1 Then GoTo 10
        If WorksheetFunction.CountA(.[a2:b50]) = x Then GoTo 30
      If .Cells(c, 1) = "" Then
      .Cells(c, 1) = a
      GoTo 20
      Else
      .Cells(c, 2) = a
        End If
    c = c + 1

20
        Next
    End With
30
    If x = 8 Then Yerlestir8: Sheets("8 'li Eşleşme").Select
    If x = 16 Then Yerlestir16: Sheets("16 'lı Eşleşme").Select
    If x = 32 Then Yerlestir32: Sheets("32 'li Eşleşme").Select
End Sub
    Sub Yerlestir8()
            With Sheets("8 'li Eşleşme")
                .Cells(9, "c") = SporcuIsmi(Sheets("Deneme").[a2]): .Cells(12, "c") = SporcuIsmi(Sheets("Deneme").[b2])
                .Cells(16, "c") = SporcuIsmi(Sheets("Deneme").[a3]): .Cells(19, "c") = SporcuIsmi(Sheets("Deneme").[b3])
                .Cells(9, "g") = SporcuIsmi(Sheets("Deneme").[a4]): .Cells(12, "g") = SporcuIsmi(Sheets("Deneme").[b4])
                .Cells(16, "g") = SporcuIsmi(Sheets("Deneme").[a5]): .Cells(19, "g") = SporcuIsmi(Sheets("Deneme").[b5])
            End With
     End Sub
Sub Yerlestir16()
        With Sheets("16 'lı Eşleşme")
            .[b9] = SporcuIsmi(Sheets("Deneme").[a2]): .[b10] = SporcuIsmi(Sheets("Deneme").[b2])
            .[b14] = SporcuIsmi(Sheets("Deneme").[a3]): .[b15] = SporcuIsmi(Sheets("Deneme").[b3])
            .[b19] = SporcuIsmi(Sheets("Deneme").[a4]): .[b20] = SporcuIsmi(Sheets("Deneme").[b4])
            .[b24] = SporcuIsmi(Sheets("Deneme").[a5]): .[b25] = SporcuIsmi(Sheets("Deneme").[b5])
            
            .[h9] = SporcuIsmi(Sheets("Deneme").[a6]): .[h10] = SporcuIsmi(Sheets("Deneme").[b6])
            .[h14] = SporcuIsmi(Sheets("Deneme").[a7]): .[h15] = SporcuIsmi(Sheets("Deneme").[b7])
            .[h19] = SporcuIsmi(Sheets("Deneme").[a8]): .[h20] = SporcuIsmi(Sheets("Deneme").[b8])
            .[h24] = SporcuIsmi(Sheets("Deneme").[a9]): .[h25] = SporcuIsmi(Sheets("Deneme").[b9])
        End With
End Sub
Sub Yerlestir32()
        With Sheets("32 'li Eşleşme")
            .[b7] = SporcuIsmi(Sheets("Deneme").[a2]): .[b8] = SporcuIsmi(Sheets("Deneme").[b2])
            .[b10] = SporcuIsmi(Sheets("Deneme").[a3]): .[b11] = SporcuIsmi(Sheets("Deneme").[b3])
            .[b13] = SporcuIsmi(Sheets("Deneme").[a4]): .[b14] = SporcuIsmi(Sheets("Deneme").[b4])
            .[b16] = SporcuIsmi(Sheets("Deneme").[a5]): .[b17] = SporcuIsmi(Sheets("Deneme").[b5])
            .[b19] = SporcuIsmi(Sheets("Deneme").[a6]): .[b20] = SporcuIsmi(Sheets("Deneme").[b6])
            .[b22] = SporcuIsmi(Sheets("Deneme").[a7]): .[b23] = SporcuIsmi(Sheets("Deneme").[b7])
            .[b25] = SporcuIsmi(Sheets("Deneme").[a8]): .[b26] = SporcuIsmi(Sheets("Deneme").[b8])
            .[b28] = SporcuIsmi(Sheets("Deneme").[a9]): .[b29] = SporcuIsmi(Sheets("Deneme").[b9])

            .[j7] = SporcuIsmi(Sheets("Deneme").[a10]): .[j8] = SporcuIsmi(Sheets("Deneme").[b10])
            .[j10] = SporcuIsmi(Sheets("Deneme").[a11]): .[j11] = SporcuIsmi(Sheets("Deneme").[b11])
            .[j13] = SporcuIsmi(Sheets("Deneme").[a12]): .[j14] = SporcuIsmi(Sheets("Deneme").[b12])
            .[j16] = SporcuIsmi(Sheets("Deneme").[a13]): .[j17] = SporcuIsmi(Sheets("Deneme").[b13])
            .[j19] = SporcuIsmi(Sheets("Deneme").[a14]): .[j20] = SporcuIsmi(Sheets("Deneme").[b14])
            .[j22] = SporcuIsmi(Sheets("Deneme").[a15]): .[j23] = SporcuIsmi(Sheets("Deneme").[b15])
            .[j25] = SporcuIsmi(Sheets("Deneme").[a16]): .[j26] = SporcuIsmi(Sheets("Deneme").[b16])
            .[j28] = SporcuIsmi(Sheets("Deneme").[a17]): .[j29] = SporcuIsmi(Sheets("Deneme").[b17])

        End With
End Sub

Function SporcuIsmi(No)
    Set s = Sheets("Kategori").Columns(2).Find(No)
    SporcuIsmi = Sheets("Kategori").Cells(s.Row, 3)
End Function
 
Üstad teşekkür ederim kod çalışıyor. fakat ben bunu bir düğmeye bağlayabilirmiyim? ikinci sorum ise tur atlar ekleyebilirmiyiz? Örneğin 29 sporcu 32 li eşleşme olacak rastgele seçimde rakibi olmayan sporcu tur atlar yazacak ve üst tura adı yazılacak. umarım anlatabilmişimdir. Adım Mustafa KIVRAK Bizim kulübümüz KSKC - Koşar Shotokan Karate Kulübü fethiye şubesi merkez kulüp kadıköy modada Hakkı KOŞAR ismini duyduğunuzu sanıyorum. tabiki müsabakalarda görüşmek dilegiyle.
 
Bu şekilde dener misiniz ?
Hocam, sayfalardaki tablo yapılarında değişiklik yapmayın yoksa kodlar doğru çalışmaz.
Kod: 
Sub RasgeleSporcu()
'Eski kodu silip bu kodu ekleyin.
    c = 2
    x = InputBox("Kaçlı Eşleme Yapmak İstiyor Sunuz ?", , 8)
    With Sheets("Deneme")
    .[a2:b100].Clear
    For i = 1 To 32
10
        Randomize

        a = Int((32 * Rnd) + 1)
        If WorksheetFunction.CountIf(.[a:b], a) = 1 Then GoTo 10
        If WorksheetFunction.CountA(.[a2:b50]) = x Then GoTo 30
      If .Cells(c, 1) = "" Then
      .Cells(c, 1) = a
      GoTo 20
      Else
      .Cells(c, 2) = a
        End If
    c = c + 1

20
        Next
    End With
30
    If x = 8 Then Yerlestir8: Sheets("8 'li Eşleşme").Select
    If x = 16 Then Yerlestir16: Sheets("16 'lı Eşleşme").Select
    If x = 32 Then Yerlestir32: Sheets("32 'li Eşleşme").Select
[COLOR=RED]    SporcuYoksa[/COLOR]
End Sub
Kod: 
Sub SporcuYoksa()

'8 li grup için
arr = Array(9, 12, 16, 19)
For i = 0 To UBound(arr)
    If Sheets("8 'li Eşleşme").Cells(arr(i), 3) = "" Then Sheets("8 'li Eşleşme").Cells(arr(i), 3) = "TUR ATLAR"
    If Sheets("8 'li Eşleşme").Cells(arr(i), "G") = "" Then Sheets("8 'li Eşleşme").Cells(arr(i), "g") = "TUR ATLAR"
Next
'16 lı grup için
arr2 = Array(9, 10, 14, 15, 19, 20, 24, 25)
For i = 0 To UBound(arr2)
    If Sheets("16 'lı Eşleşme").Cells(arr2(i), 2) = "" Then Sheets("16 'lı Eşleşme").Cells(arr2(i), 2) = "TUR ATLAR"
    If Sheets("16 'lı Eşleşme").Cells(arr2(i), "h") = "" Then Sheets("16 'lı Eşleşme").Cells(arr2(i), "h") = "TUR ATLAR"
Next
'32 li grup için
For i = 7 To 29
    If i Mod 3 = 0 Then GoTo 30
    If Sheets("32 'li Eşleşme").Cells(i, 2) = "" Then Sheets("32 'li Eşleşme").Cells(i, 2) = "TUR ATLAR"
    If Sheets("32 'li Eşleşme").Cells(i, "J") = "" Then Sheets("32 'li Eşleşme").Cells(i, "J") = "TUR ATLAR"
30
Next
End Sub
 
Üstadım teşekkür ederim, kodlar çalışıyor sizden 1 ricam daha olacak lütfen beni bağışlayın çok yük oldum size farkındayım. ufak bir sıkıntı var listede 8 kişi var ve 8 li eşleştirme yapıyorum ama bazen 1 bazen 5 bazen 2 sporcu listeye geliyor. listede 32 kişi varsa sıkıntı yok ama 16 ve daha azı varsa eşleşme tam olmuyor. Şimdiden teşekkür ederim. İlk maçta kahveler benden :)
 
Son düzenleme:
Kodun, Kategori sayfasındaki sporcu sayısı kadar çalışmasını sağladım; böyle deneyin.
Kod: 
Sub RasgeleSporcu()
    c = 2
    x = WorksheetFunction.CountA(Sheets("Kategori").[c6:c500])
    With Sheets("Deneme")
    .[a2:b100].Clear
    For i = 1 To x
10
        Randomize

        a = Int((x * Rnd) + 1)
        If WorksheetFunction.CountIf(.[a:b], a) = 1 Then GoTo 10
        If WorksheetFunction.CountA(.[a2:b50]) = x Then GoTo 30
      If .Cells(c, 1) = "" Then
      .Cells(c, 1) = a
      GoTo 20
      Else
      .Cells(c, 2) = a
        End If
    c = c + 1

20
        Next
    End With
30
    If x <= 8 Then Yerlestir8: Sheets("8 'li Eşleşme").Select
    If x > 8 And x <= 16 Then Yerlestir16: Sheets("16 'lı Eşleşme").Select
    If x > 16 And x <= 32 Then Yerlestir32: Sheets("32 'li Eşleşme").Select
    SporcuYoksa
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst