• DİKKAT

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

Eşleşenleri Bul, Listele, Renklendir.

1Al2Ver

1Al2Ver

Katılım
5 Kasım 2007
Mesajlar
4,727
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
Merhaba,

2 farklı tabloda varolan 6'lı sayı bloklarından, birbirleri ile eşleşenlerin Listelenmesini ve Renklenmesini arzuluyorum.

Teşekkür ederim.
 

Ekli dosyalar

Merhaba
Renk her seferinde farklı mı olacak yoksa sabit bir ren mi olacak_?
 
İhsan Tank' Alıntı:
Merhaba
Renk her seferinde farklı mı olacak yoksa sabit bir ren mi olacak_?
Genişletmek için tıkla ...

Merhaba,

Öncelikle ilginiz için teşekkür ederim,

Zor olmayacaksa farklı olsun, kod uzuyor ve sistemi zorlar ise aynı olabilir,

Teşekkür ederim.
 
1Al2Ver' Alıntı:
Merhaba,

Öncelikle ilginiz için teşekkür ederim,

Zor olmayacaksa farklı olsun, kod uzuyor ve sistemi zorlar ise aynı olabilir,

Teşekkür ederim.
Genişletmek için tıkla ...

Tek renk olması daha iyi olur diye düşündüm
Boş bir module kopyalayın ve deneyin. ( Kırmızıya boyuyor )
Kod: 
Option Explicit
Sub bul_renk_aktar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
trabzonspor = MsgBox("Verileri Bulup Boyayıp Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Range("A2:F" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).ClearContents
Range("R1:X" & Rows.Count).Interior.ColorIndex = xlNone
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "Y") = Cells(ts, "A") & " " & Cells(ts, "B") & " " & Cells(ts, "C") & _
" " & Cells(ts, "D") & " " & Cells(ts, "E") & " " & Cells(ts, "F")
Next
For ts = 2 To Cells(Rows.Count, "S").End(xlUp).Row
Cells(ts, "Z") = Cells(ts, "S") & " " & Cells(ts, "T") & " " & Cells(ts, "U") & _
" " & Cells(ts, "V") & " " & Cells(ts, "W") & " " & Cells(ts, "X")
Next
kaplan = 3
For ts = 2 To Cells(Rows.Count, "Y").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Z:Z"), Cells(ts, "Y")) > 0 Then
Range("A" & ts & ":F" & ts).Interior.ColorIndex = kaplan
kaplan = kaplan + 1
End If
Next
kaplan = 1
trabzonspor = 3
For ts = 2 To Cells(Rows.Count, "Z").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Y:Y"), Cells(ts, "Z")) > 0 Then
Range("R" & ts & ":X" & ts).Interior.ColorIndex = trabzonspor
Cells(kaplan, "I") = Cells(ts, "R")
Cells(kaplan, "I").Interior.ColorIndex = trabzonspor
Range("S" & ts & ":X" & ts).Copy Destination:=Range("J" & kaplan)
kaplan = kaplan + 1
trabzonspor = trabzonspor + 1
End If
Next
Range("Y:Z").ClearContents
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Buldum Boyadım ve Aktardım", , "Bitiş"
End Sub
 
Merhaba
Bu kod daha güzel oldu
Kod: 
Option Explicit
Sub bul_renk_aktar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
trabzonspor = MsgBox("Verileri Bulup Boyayıp Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Range("A2:F" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).ClearContents
Range("R2:X" & Rows.Count).Interior.ColorIndex = xlNone
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "Y") = Cells(ts, "A") & " " & Cells(ts, "B") & " " & Cells(ts, "C") & _
" " & Cells(ts, "D") & " " & Cells(ts, "E") & " " & Cells(ts, "F")
Next
For ts = 2 To Cells(Rows.Count, "S").End(xlUp).Row
Cells(ts, "Z") = Cells(ts, "S") & " " & Cells(ts, "T") & " " & Cells(ts, "U") & _
" " & Cells(ts, "V") & " " & Cells(ts, "W") & " " & Cells(ts, "X")
Next
kaplan = 3
For ts = 2 To Cells(Rows.Count, "Y").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Z:Z"), Cells(ts, "Y")) > 0 Then
If kaplan > 56 Then
kaplan = 3
End If
Range("A" & ts & ":F" & ts).Interior.ColorIndex = kaplan
kaplan = kaplan + 1
End If
Next
kaplan = 1
trabzonspor = 3
For ts = 2 To Cells(Rows.Count, "Z").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Y:Y"), Cells(ts, "Z")) > 0 Then
If trabzonspor > 56 Then
trabzonspor = 3
End If
Range("R" & ts & ":X" & ts).Interior.ColorIndex = trabzonspor
Cells(kaplan, "I") = Cells(ts, "R")
Cells(kaplan, "I").Interior.ColorIndex = trabzonspor
Range("S" & ts & ":X" & ts).Copy Destination:=Range("J" & kaplan)
kaplan = kaplan + 1
trabzonspor = trabzonspor + 1
End If
Next
Range("Y:Z").ClearContents
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Buldum Boyadım ve Aktardım", , "Bitiş"
End Sub
 
İhsan Tank' Alıntı:
Tek renk olması daha iyi olur diye düşündüm
Boş bir module kopyalayın ve deneyin. ( Kırmızıya boyuyor )
Kod: 
Option Explicit
Sub bul_renk_aktar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
trabzonspor = MsgBox("Verileri Bulup Boyayıp Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Range("A2:F" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).Interior.ColorIndex = xlNone
Range("I1:O" & Rows.Count).ClearContents
Range("R[COLOR="Red"]1[/COLOR]:X" & Rows.Count).Interior.ColorIndex = xlNone
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "Y") = Cells(ts, "A") & " " & Cells(ts, "B") & " " & Cells(ts, "C") & _
" " & Cells(ts, "D") & " " & Cells(ts, "E") & " " & Cells(ts, "F")
Next
For ts = 2 To Cells(Rows.Count, "S").End(xlUp).Row
Cells(ts, "Z") = Cells(ts, "S") & " " & Cells(ts, "T") & " " & Cells(ts, "U") & _
" " & Cells(ts, "V") & " " & Cells(ts, "W") & " " & Cells(ts, "X")
Next
kaplan = 3
For ts = 2 To Cells(Rows.Count, "Y").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Z:Z"), Cells(ts, "Y")) > 0 Then
Range("A" & ts & ":F" & ts).Interior.ColorIndex = kaplan
kaplan = kaplan + 1
End If
Next
kaplan = 1
trabzonspor = 3
For ts = 2 To Cells(Rows.Count, "Z").End(xlUp).Row
If WorksheetFunction.CountIf(Range("Y:Y"), Cells(ts, "Z")) > 0 Then
Range("R" & ts & ":X" & ts).Interior.ColorIndex = trabzonspor
Cells(kaplan, "I") = Cells(ts, "R")
Cells(kaplan, "I").Interior.ColorIndex = trabzonspor
Range("S" & ts & ":X" & ts).Copy Destination:=Range("J" & kaplan)
kaplan = kaplan + 1
trabzonspor = trabzonspor + 1
End If
Next
Range("Y:Z").ClearContents
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Buldum Boyadım ve Aktardım", , "Bitiş"
End Sub
Genişletmek için tıkla ...

Sayın İhsan Tank merhaba,

Elinize sağlık, hatasız çalışıyor,

SONUÇ (R1:X1) rengini silmemesi için koddaki R1'i R2 yaptım,

Range("R2:X" & Rows.Count).Interior.ColorIndex = xlNone

Tekrar teşekkür ederim.

Saygılarımla.

5 nolu mesajı görmeden cevap yazmıştım, siz zaten düzeltmişsiniz,

Bunun dışında yeni kodda bir fark var mı ?
 
1Al2Ver' Alıntı:
Sayın İhsan Tank merhaba,

Elinize sağlık, hatasız çalışıyor,

SONUÇ (R1:X1) rengini silmemesi için koddaki R1'i R2 yaptım,

Range("R2:X" & Rows.Count).Interior.ColorIndex = xlNone

Tekrar teşekkür ederim.

Saygılarımla.

5 nolu mesajı görmeden cevap yazmıştım, siz zaten düzeltmişsiniz,

Bunun dışında yeni kodda bir fark var mı ?
Genişletmek için tıkla ...

Var rengin 56 index'si mevcut ilk koda bu kıstasa girmeyi unutmuşum ikinci kod bu yüzden daha kullanışlı oldu :)
Karar sizin.
 
İhsan Tank' Alıntı:
Var rengin 56 index'si mevcut ilk koda bu kıstasa girmeyi unutmuşum ikinci kod bu yüzden daha kullanışlı oldu :)
Karar sizin.
Genişletmek için tıkla ...

Tekrar merhaba,

Evet daha kullanışlı ve görselliği de daha güzel, tekrar teşekkür ederim.

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