Karşılaştırmalı Toplama

[quman]

Merhaba arkadaşlar, herkese iyi çalışmalar..

2 adet excel kitabım var. Dosyalar ve Riskler adında. Dosyalar kitabımda, A sütununda sayısı 2000-3000 arasında hesap numaraları var (hesap numaraları ve sayısı her seferinde değişiyor). Riskler kitabının adını bildiğim bir sayfasında da 2 sütun var. A sütunu hesap numarası, burada yaklaşık 20.000 hesap nosu ve yanındaki B sütununuda da bu hesaplara ait riskler var. Dosyalar kitabındaki hesap numaralarını Riskler kitabında hesap numarası bazında arayarak (olmayabilir de) varsa yanındaki riski toplamak ve Dosyalar kitabının B1 hücresine toplamı yazmak istiyorum. Aynı hesap numarasına ait birden fazla risk bilgisi olabilir. Örnek dosyalar ektedir.

Çözüm olarak döngü düşündüm ama 3.000*20.000 çok uzun olacak gibi ve bu işlemi farklı hesap numaraları ile 30-50 defa tekrarlamam gerekiyor.Bu konuda nasıl bir makro yazılabilir? Yardımlarınızı rica ediyorum. Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

İki dosyanızıda aynı klasör içine yerleştirdikten sonra aşağıdaki kodu "Dosyalar" isimli dosyanızda çalıştırın.

Option Explicit
 
Sub TOPLAM_RİSK()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, İlk As Date
    
    İlk = Time
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Open(K1.Path & "\Riskler.xlsx")
    Set S1 = K1.Sheets(1)
    Set S2 = K2.Sheets(1)
    
    K1.Activate
    S1.Range("B1") = ""
    
    For X = 3 To S1.Cells(Rows.Count, 1).End(3).Row
        S1.Range("B1") = S1.Range("B1") + WorksheetFunction.SumIf(S2.Range("A:A"), S1.Cells(X, 1), S2.Range("B:B"))
    Next
 
    K2.Close
    Set K1 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
    "İşlem süresi ; " & Format(Time - İlk, "hh:mm:ss"), vbInformation
End Sub

 

[quman]

Sayın Korhan Ayhan, yardımınız için çok teşekkür ederim, elinize sağlık. İstediğim buydu, sorunum çözüldü ve açıkçası beklediğimden çok kısa sürdü işlem zamanı. Hayırlı günler..

 

[assenucler]

Sayın quman;

Merhabalar..

Konu çok ilgimi çekti. Kodları nasıl kullanacağımı bilmiyorum. Sayın Korhan Ayhan'ın önerdiği çözüme göre, dosyanın son şeklini sitemize ekleyebilir misiniz?

Emek ve katkılarınız için teşekkürler.

Teşekkürler.

 

[quman]

Sayın assenucler,

Yaptığım sadece kodları Dosyalar kitabının içinde Module açıp kopyalayıp yapıştırmak. Bu nasıl oluyor diyorsanız :

Dosyalar kitabını açın, Alt+F11 ile VB Editörünü açın. Solda Project kısmında Dosyalar.xls'in üstünde sağ tuş yapıp yeni modül ekleyin. Sonra modülü çift tıklayıp sağdaki boş beyaz alana kodları olduğu gibi yapıştırın. Run tuşuna basınca mucizeyi göreceksiniz İyi çalışmalar. Sn.Korhan Bey'e bu vesile ile tekrar teşekkürler.

Not : Kodların kopyalanmış hali olan Dosyalar.xlsm uzantılı dosyayı yüklemiyorum. Eğer makro içeren Excel 2010 dosyası engelenmişse olabilir. Kendiniz yukarıdaki gibi yapınız.

 

[assenucler]

Bir soru ve istek.

Sayın quman,


Merhabalar. Yanıtınız için teşekkürler.

"riskler toplamı" "B1" hücresine çok hızlı aktarılıyor.

Eski bir bankacı olarak, B1 sütununda toplam risk ve her hesabın yanında da, o hesabın riski yazılsa daha iyi olmaz mı?

Sayın Korhan Ayhan üstadımızın uygun olduğu bir zaman, bunu da yapabileceğini düşünüyorum.

Emek ve katkılar için bir kez daha teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Satır bazında toplamlar için aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub TOPLAM_RİSK()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, İlk As Date
 
    İlk = Time
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Open(K1.Path & "\Riskler.xlsx")
    Set S1 = K1.Sheets(1)
    Set S2 = K2.Sheets(1)
 
    K1.Activate
    S1.Range("B1") = ""
 
    For X = 3 To S1.Cells(Rows.Count, 1).End(3).Row
        S1.Cells(X, 2) = WorksheetFunction.SumIf(S2.Range("A:A"), S1.Cells(X, 1), S2.Range("B:B"))
    Next
 
    S1.Range("B1") = WorksheetFunction.Sum(S1.Range("B3:B" & Rows.Count))
 
    K2.Close
    Set K1 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
    "İşlem süresi ; " & Format(Time - İlk, "hh:mm:ss"), vbInformation
End Sub

 

[assenucler]

Değerli üstadım;

İyi akşamlar.

Sağ olun var olun.. İyi ki varsınız.

Sevgi ve saygılar.

 

[assenucler]

Sayın Korhan Ayhan;

İyi geceler.

Kodunuzu "Module" yapıştırdıktan sonra kaydetmek istediğimde, resimdeki iletiyi alıyorum. 20 dakikadır uğraşıyorum. Bir türlü modul'ü kaydedemiyorum.. Nerede eksik ya da hatalı işlem yapıyorum, bulamadım.

Sizden rica etsem, sayın quman'ın dosyasına bu kodu ekleyebilir misiniz?

Teşekkürler.

 

[assenucler]

Sorun devam ediyor...

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki koda küçük bir ekleme daha yaptım.

Dosyayı farklı kaydet yapıp dosya türü bölümünden "Makro içeren dosya" şeklinde kayıt etmeyi deneyin.

 

[assenucler]

Teşekkürler.