- Katılım
- 5 Kasım 2007
- Mesajlar
- 4,727
- Excel Vers. ve Dili
- 64 Bit TR - Microsoft Office 365 - Win11 Home
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba,
4 ligin takımları ve maç skorları olan sayfadan "Süz" sayfasına seçilen takıma göre fikstürü almak istiyorum,
Örnek dosya ve açıklamalar ek'tedir,
Teşekkür ederim,
NOT ; Makro ile de olabilir.
Option Explicit
Sub aktar()
Dim ts, kaplan, trabzonspor
trabzonspor = MsgBox(Sheets("Süz").Range("J1") & " Takımının" _
& " Maçlarını Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
Sheets("Süz").Range("F18:M51").ClearContents
kaplan = 18
For ts = 2 To Sheets("GENEL").Cells(65536, "B").End(xlUp).Row
If Sheets("GENEL").Cells(ts, "C") = WorksheetFunction.Proper(Sheets("Süz").Range("J1")) _
Or Sheets("GENEL").Cells(ts, "F") = WorksheetFunction.Proper(Sheets("Süz").Range("J1")) Then
Sheets("Süz").Cells(kaplan, "G") = Sheets("GENEL").Cells(ts, "B") 'tarih
Sheets("Süz").Cells(kaplan, "H") = Sheets("GENEL").Cells(ts, "C") '1.takım
Sheets("Süz").Cells(kaplan, "I") = Sheets("GENEL").Cells(ts, "D") '1'skor
Sheets("Süz").Cells(kaplan, "J") = Sheets("GENEL").Cells(ts, "F") '2.takım
Sheets("Süz").Cells(kaplan, "K") = Sheets("GENEL").Cells(ts, "E") '2.skor
If Sheets("Süz").Cells(kaplan, "I") = "" And Sheets("Süz").Cells(kaplan, "K") = "" Then
Sheets("Süz").Cells(kaplan, "L") = ""
ElseIf Sheets("Süz").Cells(kaplan, "I") = Sheets("Süz").Cells(kaplan, "K") Then
Sheets("Süz").Cells(kaplan, "L") = "B"
ElseIf Sheets("Süz").Cells(kaplan, "H") = WorksheetFunction.Proper(Sheets("Süz").Range("J1")) Then
If Sheets("Süz").Cells(kaplan, "I") > Sheets("Süz").Cells(kaplan, "K") Then
Sheets("Süz").Cells(kaplan, "L") = "G"
Else
Sheets("Süz").Cells(kaplan, "L") = "M"
End If
ElseIf Sheets("Süz").Cells(kaplan, "J") = WorksheetFunction.Proper(Sheets("Süz").Range("J1")) Then
If Sheets("Süz").Cells(kaplan, "K") > Sheets("Süz").Cells(kaplan, "I") Then
Sheets("Süz").Cells(kaplan, "L") = "G"
Else
Sheets("Süz").Cells(kaplan, "L") = "M"
End If
End If
If Sheets("Süz").Cells(kaplan, "L") = "G" Then
Sheets("Süz").Cells(kaplan, "M") = 3
ElseIf Sheets("Süz").Cells(kaplan, "L") = "B" Then
Sheets("Süz").Cells(kaplan, "M") = 1
ElseIf Sheets("Süz").Cells(kaplan, "L") = "M" Then
Sheets("Süz").Cells(kaplan, "M") = 0
End If
kaplan = kaplan + 1
Sheets("Süz").Range("F18") = 1
Sheets("Süz").Cells(kaplan, "F") = WorksheetFunction.Max(Range("F18:F" & kaplan - 1)) + 1
End If
Next
Application.ScreenUpdating = True
MsgBox Sheets("Süz").Range("J1") & " Takımının Maçlarını Aktardım", _
vbInformation, "Bitiş"
End Sub
İhsan bey merhaba,
Öncelikle emeğiniz ve ilginiz için teşekkür ederim, sağolun,
Küçük bir sorun var,
F sütunundaki sıra no.su F18 den başlamalı, hali hazırda sıra no vermeye F19 dan başlıyor, kod'da düzeltilecek yer neresidir ?
Teşekkür ederim.
Üstteki kodu güncelledim.
Kusura bakmayın o noktayı atlamışım
İhsan bey tekrar merhaba,
Rica ederim, kusur ne kelime,
Süper Ligden takım seçildiğinde F52 ye 35 yazıyor, F52'nin boş olması gerekir (malum SüperLig 34 hafta),
Çok sorun değil o satırı beyaz renk ile aşabilirim, bilginiz olsun istedim,
Tekrar teşekkür ederim,
Saygılarımla.
İhsan bey merhaba,
Fikstürü uyarınız gereği düzenledim,
Teşekkür ederim.