Veri Çağırma Makrosu

[Mustafa MUTLU]

Siteden aldığım aşağıdaki makro ile veri çaırabiliyorum.
Ancak 1 kişinin verisini çağırıyorum.
Benim 20-30 (daha da artabilir) civarında öğrencim var.
Her hafta bazılarına 2 kez ant. sonucu giriyorum.

Benim isteğim ise:
Sayfaya bu maro ile 1 kişi nin verisini çağırmak yerine
Tüm oyuncuların verisini alt alta sıralamak istiyorum.

Örneğin:
ali için 3 veri girişi yapmışım
veli için 5 veri
ayşe için 1 veri
fatma için 8 veri girişi yapmışım.
Raporu istediğimde
(İsim Sıralaması önemli değil)
Ali : xxx
Ali : xxx
Ali : xxx
Veli : xxx
Veli : xxx
Veli : xxx
Veli : xxx
Veli : xxx
Ayşe : xxx
Fatma : xxx
gibi sıralasın istiyorum.




Sub SearchText()
Dim k As Range, ilk_adres As String, sat As Long, sut As Byte
Sheets("KONTROL").Select

Range("A11:AB300") = ""
If MsgBox("[ " & Range("B4").Value & " ] İsimli sahısı aramak istiyormusunuz?", vbYesNo + vbQuestion, "ARAMA") = vbNo Then Exit Sub
Application.ScreenUpdating = False
Range("A11:AB65536").ClearContents
sat = 11
Set k = Sheets("ANTGİRİŞİ").Range("B2:AB65536").Find(Range("B4").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
ilk_adres = k.Address
Do
Cells(sat, "A").Value = sat - 10
For sut = 0 To 30
Cells(sat, k.Offset(0, sut).Column).Value = k.Offset(0, sut).Value
Next sut
sat = sat + 1
Set k = Sheets("ANTGİRİŞİ").Range("B2:AB65536").FindNext(k)
Loop While k.Address <> ilk_adres And Not k Is Nothing
End If
Set k = Nothing
Application.ScreenUpdating = True
If sat > 11 Then
MsgBox "Arama Tamamlandı..", vbOKOnly + vbInformation, Application.ScreenUpdating = True
End If
End Sub

Teşekkür ederim....

 

[Korhan Ayhan]

Selamlar,

Örnek dosya eklermisiniz.

 

[Mustafa MUTLU]

Ekliyorum..
Ben 1 kişi çağırabiliyorum.
Çoklu çağırma yada Sayfa1 de olan isimlerin hepsini de çağırabilir..

İlgine Teşekkür ederim...

 

[Korhan Ayhan]

Selamlar,

Sayfanıza yeni bir buton oluşturup aşağıdaki kodu tanımlayın. Bu şekilde dilerseniz tek oyuncu bilgilerini dilerseniz tüm oyuncu bilgilerini ayrı ayrı aktarabilirsiniz.

Sub TÜMÜNÜ_SIRALI_AKTAR()
    If MsgBox("Tüm oyuncu bilgilerini aktarmak istiyor musunuz ?", vbYesNo + vbQuestion, "ONAY") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Sheets("KONTROL").Select
    Range("A11:O65536").ClearContents
    
    Range("B11:O65536").Font.Bold = True
    Range("O11:O65536").NumberFormat = "dd.mm.yyyy"
    Range("A11:O" & Sheets("ANTGİRİŞİ").Range("A65536").End(3).Row + 9).Value = Sheets("ANTGİRİŞİ").Range("A2:O" & Sheets("ANTGİRİŞİ").Range("A65536").End(3).Row).Value
    Range("B11:O65536").Sort Key1:=Range("B11"), Order1:=xlAscending
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Mustafa MUTLU]

Teşekkür ederim..