Ayırma için Makro Yardım

4

4yaKuza

Katılım
28 Eylül 2017
Mesajlar
23
Excel Vers. ve Dili
2013 TR
Arkadaşlar merhaba öncelikle yapmak istediğim bir şey var düşün taşın nasıl yapacağımı bilemedim bende yardım amaçlı yapıcam hocam istedi sen yaparsın uğraş dedi ama işin içinden çıkamadım.

Amaç : Her hafta Hakem listesi yayınlanıyor. Aynı hakemin son 2 hafta içinde aynı takımın maçına verilmemesi. Denk gelmemesi.

Yani ;

http://s4.dosya.tc/server5/tjxnf6/TumAtamalar_hafta_17.xls.html
Burada son hafta excel dosyası var ben geçmişteki 2 tane haftanın maçlarına gelmesin istiyorum. Yani bir hakem ismi aynı takımın maçına çıkmasın diğer 2 excel dosyasından kontrol edilsin.

son 2 incelenecek örnek dosya
http://s4.dosya.tc/server5/7qkkkp/TumAtamalar_hafta_16.xls.html
http://s4.dosya.tc/server5/vsfiha/TumAtamalar_hafta_15.xls.html

Hoca her hafta yayınlıyor mesela bu hafta 18. haftayı yayınlıyacak. Bana diyorki 17 ile 16. haftayı kontrol et hepsini tek tek çıkan varsa aynı takımlara bana söyle diyor. buda çok zaman alıyor bende çalışan insanım yardım amaçlı istiyor kendisde bir gelir elde etmiyor. bende etmiyorum. birlikten kuvvet doğar misali.
Yardımlarınızı bekliyorum arkadaşlar nasıl bir yol izleyebiliirim
şöyle yapabilirmiyim.
Yeni excel de 1. sayfaya geçmiş son 2 haftayı ekleyeceğim hep kopyala yapışyırla.
2. sayfaya da en son hocanın yayınlayacağını yapıştıracam.
bi macro tuşuna basacam. örnek bir hakem galatasaray fenerbahçe maçina çıkmış ali diye hakem bu ali diye hakem son liste de galatasaray-trabzon veya fenerbahçe-akhisar maçına çıkmasın yani bu 2 takıma son 2 hafta da zaten çıkmış.
bunları macro tuşuyla bulup ya hücreyi boyasın ya yazı rengi kalınlaşssın yada 3. sayfaya bu isimleri çeksin yazsın fikire açık ben bu konularda tecrübeli değilim sizlere danışayım dedim

Örnek olarak ve Detaylı anlatım için excel oluşturdum burdan yürürsek daha faydalı olabilir Lütfen yardımlarınızı bekliyorum
http://s4.dosya.tc/server5/9gpkud/ORNEK_OLABILIR.xlsx.html
 
Son düzenleme:
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,680
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Aşağıdaki şekilde deneyiniz

http://dosya.co/v4pxqhtb51fi/HAKEM_ORNEK_OLABILIR.xlsm.html

Kod: 
Dim hafta, hafta2 As String

Sub menu()
    Application.ScreenUpdating = False
    Call bulmaya_hazirlik
    Call bulbakalim
    Call bulunmayani_sil
    Application.ScreenUpdating = True
End Sub

Sub bulunmayani_sil()
   sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = sonsatir To 2 Step -1
        renk1 = Cells(i, "F").Interior.Color
        renk2 = Cells(i, "H").Interior.Color
        renk3 = Cells(i, "J").Interior.Color
 
        If renk1 = 255 Or renk2 = 255 Or renk3 = 255 Then
           
        Else
           Rows(i).Delete
        End If
        
    Next i
    Columns("I").Delete
    Columns("G").Delete
End Sub

Sub bulbakalim()
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 2 To sonsatir
        hafta = Cells(i, "A").Value
        hafta2 = Cells(i + 1, "A").Value
        
        evsahibi = Cells(i, "G").Value
        evsahibi2 = Cells(i + 1, "G").Value
        misafir = Cells(i, "I").Value
        misafir2 = Cells(i + 1, "I").Value
        
        If (hafta = "1" And hafta2 = "2") And evsahibi = evsahibi2 Then
            Cells(i, "F").Interior.Color = 255
            Cells(i + 1, "F").Interior.Color = 255
            Cells(i, "J").Interior.Color = 255
            Cells(i + 1, "J").Interior.Color = 255
            
        End If
    
        If (hafta = "1" And hafta2 = "2") And misafir = misafir2 Then
            Cells(i, "H").Interior.Color = 255
            Cells(i + 1, "H").Interior.Color = 255
            Cells(i, "J").Interior.Color = 255
            Cells(i + 1, "J").Interior.Color = 255
        End If
    Next i
End Sub


Sub bulmaya_hazirlik()
    Application.DisplayAlerts = False
    If WorksheetExists("SONUC") Then
      Sheets("SONUC").Delete
    End If
    Application.DisplayAlerts = True
    
    Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
    newsh.Name = "SONUC"
    
    Sheets("SON 2 HAFTA").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Rows("2:" & sonsatir).Select
    Selection.Copy
    Sheets("SONUC").Select
    Range("A1").Select
    ActiveSheet.Paste
    Cells.Select
    
    Cells.EntireColumn.AutoFit
    
    Cells.Select
    Application.CutCopyMode = False
    Selection.UnMerge
    Range("A1").Select

    
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("A2").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    Selection.AutoFill Destination:=Range("A2:A" & sonsatir)
    Range("A2:A" & sonsatir).Select
    Range("A2").Select
    Sheets("SON HAFTA").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Rows("3:" & sonsatir).Select
    Selection.Copy
    Sheets("SONUC").Select
    ActiveWindow.SmallScroll Down:=-12
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    Range("A" & sonsatir).Select
    ActiveSheet.Paste
    Range("A" & sonsatir).Select
    Range(Selection, Selection.End(xlDown)).Select

    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A" & sonsatir).Select
    ActiveCell.FormulaR1C1 = "1"
    sonsatir2 = Cells(Rows.Count, "B").End(3).Row
    Selection.AutoFill Destination:=Range("A" & sonsatir & ":A" & sonsatir2)
    'Boş satır sil
    For i = sonsatir2 To 2 Step -1
       If Cells(i, "D").Value = "" Or Cells(i, "D").Value = "SAHA" Then
         Rows(i).Delete
       End If
    Next i    
    
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1] & ""/"" &RC[2]"
    
    Range("G2").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    Selection.AutoFill Destination:=Range("G2:G" & sonsatir)
    Range("G2:G" & sonsatir).Select
    Columns("G:G").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G5").Select
    Application.CutCopyMode = False
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1] &""/"" & RC[1]"
    Range("I2").Select
    
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    Selection.AutoFill Destination:=Range("I2:I" & sonsatir)
    Range("I2:I" & sonsatir).Select
    Columns("I:I").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("I7").Select
    Application.CutCopyMode = False
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "evsahibi"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "misafir"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "hafta"
    
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Add Key:=Range("G2:G" & sonsatir) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Add Key:=Range("A2:A" & sonsatir) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("SONUC").Sort
        .SetRange Range("A1:O" & sonsatir)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("C1").Select
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Add Key:=Range("I2:I" & sonsatir) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("SONUC").Sort.SortFields.Add Key:=Range("A2:A" & sonsatir) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("SONUC").Sort
        .SetRange Range("A1:O" & sonsatir)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function
 
Son düzenleme:
4

4yaKuza

Katılım
28 Eylül 2017
Mesajlar
23
Excel Vers. ve Dili
2013 TR
abi çok teşekkür ederim vermiş olduğun data oldu bu formülü de oradaki kontrol et butonundaki formul mu ?
 
4

4yaKuza

Katılım
28 Eylül 2017
Mesajlar
23
Excel Vers. ve Dili
2013 TR
Hocam sayın @asri ilk etapda oldu sandım ama olmamış "SON HAFTA" Sayfasındaki Sarı stündaki bir takımın karşısına hakem yazıyorum örnek EMRE TUTAY ve "SON 2 HAFTA" sayfasındaki aynı takımın karşısına da EMRE TUTAY yazıyorum kontrol et diyorum SONUÇ" a getirmiyor. sildim linkten yeniden inip denedim gene olmuyor
Kontrol edermisiniz tekrardan?
yardımlarııza ihtiyacim var teşekkür edeirim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst