- Katılım
- 12 Eylül 2021
- Mesajlar
- 45
- Excel Vers. ve Dili
- Microsoft Office 2016 Türkçe
- Altın Üyelik Bitiş Tarihi
- 01-03-2024
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Ozet_Rapor()
Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Zaman As Double
Dim Son As Long, Veri As Variant, X As Long, Aranan As String, Say As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Zaman = Timer
Set S1 = Sheets("DATA")
Set S2 = Sheets("RAPOR")
Set Dizi = CreateObject("Scripting.Dictionary")
S2.Range("A2:D" & S2.Rows.Count).Clear
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
Veri = S1.Range("A2:K" & Son).Value
ReDim Liste(1 To Son, 1 To 4)
For X = LBound(Veri) To UBound(Veri)
Aranan = Veri(X, 2)
If Not Dizi.Exists(Aranan) Then
Say = Say + 1
Dizi.Add Aranan, Say
Liste(Say, 1) = Veri(X, 4)
Liste(Say, 2) = Veri(X, 2)
Liste(Say, 3) = Veri(X, 11)
If Veri(X, 11) < 0 Then
Liste(Say, 4) = "Fazla"
Else
Liste(Say, 4) = "Eksik"
End If
Else
Liste(Dizi.Item(Aranan), 3) = Liste(Dizi.Item(Aranan), 3) + Veri(X, 11)
If Liste(Dizi.Item(Aranan), 3) < 0 Then
Liste(Dizi.Item(Aranan), 4) = "Fazla"
Else
Liste(Dizi.Item(Aranan), 4) = "Eksik"
End If
End If
Next
If Say > 0 Then
S2.Range("A2").Resize(Say, 4) = Liste
S2.Range("A2").Resize(Say, 4).Sort S2.Range("A2"), xlAscending
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbExclamation
Else
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Veri bulunamadı!" & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbExclamation
End If
Set S1 = Nothing
Set S2 = Nothing
Set Dizi = Nothing
End Sub