DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Listele()
Dim i As Long, _
j As Long, _
Yil As Integer, _
d As Object, _
Deger As Variant, _
s1 As Worksheet, _
s2 As Worksheet, _
Liste
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Yil = s2.Range("G2")
i = s2.Cells(Rows.Count, "A").End(3).Row
If i < 3 Then i = 3
s2.Range("A3:F" & i).ClearContents
For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
If s1.Cells(i, "M") = Yil Then
Deger = s1.Cells(i, "B") & "|" & s1.Cells(i, "C") & "|" & s1.Cells(i, "L")
If Not d.exists(Deger) Then
d.Add Deger, vbNull
End If
End If
Next i
Liste = d.keys
j = 3
For i = 0 To UBound(Liste)
s2.Cells(j, "A") = Split(Liste(i), "|")(0)
s2.Cells(j, "B") = Split(Liste(i), "|")(1)
s2.Cells(j, "F") = Split(Liste(i), "|")(2)
j = j + 1
Next i
Set d = Nothing
Set Liste = Nothing
If j > 3 Then
s2.Cells(j, "A") = "TOPLAM"
s2.Cells(j, "C").Formula = "=SUM(C3:C" & j - 1 & ")"
s2.Cells(j, "D").Formula = "=SUM(D3:D" & j - 1 & ")"
s2.Cells(j, "E").Formula = "=SUM(D3:D" & j - 1 & ")"
End If
Application.ScreenUpdating = True
MsgBox "LİSTELEME BİTMİŞTİR...", vbInformation, "EXCEL.WEB.TR"
End Sub