acil yardım ederseniz sevinirim şimdiden teşekkürler

bi eklenti daha var dosyayı yeniden ekliyorum acil yardım şimdiden teşekkürler.

Kimse müneccim değil. Ne istediğini söylemeden kimse sana yardım edemez. Yardım dan kastın maddi yardım ise, Sosyal Yardımlaşma vakfına müracaat edebilirsiniz.

Merhaba
Boş bir module kopyalayın ve deneyin

Kod: Tümünü seç

Option Explicit
Sub standarttan_büyük_olanlar_1967()
'Konu     :   3'den Büyük Olanları Boya ve Aktar
'Mail     :   [url=mailto:m.batu.1967@gmail.com]m.batu.1967@gmail.com[/url]
'Msn      :   [url=mailto:m.batu.1967@hotmail.com.tr]m.batu.1967@hotmail.com.tr[/url]
'Coder By   :   asi_kral_1967
Dim asi As Long, kral As Long
Dim a As New Collection, b As Range
On Error Resume Next
Range("B:C").Interior.Color = xlNone
kral = 1
For asi = 4 To Range("B" & Rows.Count).End(xlUp).Row
If WorksheetFunction.SumIf(Range("B:B"), Cells(asi, "B"), _
Range("C:C")) >= 3 Then
a.Add Cells(asi, "B"), CStr(Cells(asi, "B"))
Range("B" & asi & ":C" & asi).Interior.Color = vbYellow
End If: Next
For Each b In a
Cells(kral, "G") = b
Cells(kral, "H") = WorksheetFunction.SumIf(Range("B:B"), b, _
Range("C:C"))
kral = kral + 1
Next
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub


Dosyanız Ekte.