Eğer Fonksiyonuna Benzer Makro

my_gan · 20 Kasım 2020

Herkese merhaba. Ekte paylaştığım örnek çalışmayı buradan Ömer Bey ve Korhan Ayhan Bey'in yardımları sayesinde oluşturdum. Kendilerine tekrardan teşekkür ediyorum. Bu çalışmaya bir özellik daha eklemek istiyorum.

Ekte paylaştığım veride F sütununa çift tıklandığında ikinci sekmede yer alan "Mahsup Fişi" adlı sayfaya ilgili fişin görüntüsü geliyor. Şİmdi yapmak istediğim M stünuna açmış olduğum "karşı hesap" başlığı altına istediğim şartları taşıyan verilerin otomatik gelmesi.

Şart : A Hücresinde yer alan hesap tutarının alacak başlığı (I sütunu) altında veri varsa B1-2020000026 fişin içinde yer alan borç (H sütunun) başlığına isabet eden A Hücresinde yazan tutarlar. yada tam tersi A Hücresinde yer alan hesap tutarının borç başlığı altında veri varsa B1-2020000026 fişin içinde yer alan alacak başlığına isabet eden A Hücresinde yazan tutarlar.

Örnek: A2 Hücresi Alacak çalışmış, A2 hücresi ile aynı olan fiş numarasında yer alan yani B1-2020000026 fişindeki borç çalışan kebir başlığı altındaki veriler.(Yani 320 ile 335 )

Umarım anlatabilmişimdir. Yardımcı olacaklara şimdiden çok teşekkür ediyorum.

İndir örnek çalışma

Dosyayı indir örnek çalışma

dosya.co

my_gan · 22 Kasım 2020

Herkese merhaba tekrardan. Sanırım istediğim durumu tam anlatamadım. Eğer ve düşeyara formülünü makro olarak kullanmak istiyorum.
Formül olarak bile tam yapamadım ama yine de anlatacak olursam;

M2 Hücresi içerisine aşağıdaki formülü yapmaya çalışıyorum;
=EĞER(H2=<0;DÜŞEYARA(F SÜTUNUNDAKİ FİŞ NUMARALARI AYNI OLANLARIN H STÜNLARININ A STÜNLARI KARŞILIĞINDA YAZAN VERİLERİ GETİR);H2>0;DÜŞEYARA(F SÜTUNUNDAKİ FİŞ NUMARALARI AYNI OLANLARIN I STÜNLARININ A STÜNLARI KARŞILIĞINDA YAZAN VERİLERİ GETİR)

Korhan Ayhan · 24 Kasım 2020

Deneyiniz.

C++:

Option Explicit

Sub Karsi_Hesaplari_Listele()
    Dim S1 As Worksheet, Bul As Range, Adres As String
    Dim X As Long, Borc_Hesap As String, Alacak_Hesap As String
    
    Set S1 = Sheets("Muavin")
    
    S1.Range("M2:M" & S1.Rows.Count).ClearContents
    
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 6) <> "" Then
            Set Bul = S1.Range("F:F").Find(S1.Cells(X, 6), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Offset(, 2) > 0 Then
                        If Borc_Hesap = "" Then
                            Borc_Hesap = "-" & Bul.Offset(, -5)
                        Else
                            If InStr(1, Borc_Hesap, "-" & Bul.Offset(, -5)) = 0 Then
                                Borc_Hesap = Borc_Hesap & "-" & Bul.Offset(, -5)
                            End If
                        End If
                    Else
                        If Alacak_Hesap = "" Then
                            Alacak_Hesap = "-" & Bul.Offset(, -5)
                        Else
                            If InStr(1, Alacak_Hesap, "-" & Bul.Offset(, -5)) = 0 Then
                                Alacak_Hesap = Alacak_Hesap & "-" & Bul.Offset(, -5)
                            End If
                        End If
                    End If
                    Set Bul = S1.Range("F:F").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
        
        If Alacak_Hesap <> "" Then
            If S1.Cells(X, 8) > 0 Then S1.Cells(X, 13) = Mid(Alacak_Hesap, 2, Len(Alacak_Hesap) - 1)
        End If
                    
        If Borc_Hesap <> "" Then
            If S1.Cells(X, 9) > 0 Then S1.Cells(X, 13) = Mid(Borc_Hesap, 2, Len(Borc_Hesap) - 1)
        End If
        Borc_Hesap = ""
        Alacak_Hesap = ""
    Next

    Set Bul = Nothing
    Set S1 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

my_gan · 24 Kasım 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Karsi_Hesaplari_Listele()
    Dim S1 As Worksheet, Bul As Range, Adres As String
    Dim X As Long, Borc_Hesap As String, Alacak_Hesap As String
   
    Set S1 = Sheets("Muavin")
   
    S1.Range("M2:M" & S1.Rows.Count).ClearContents
   
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 6) <> "" Then
            Set Bul = S1.Range("F:F").Find(S1.Cells(X, 6), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Offset(, 2) > 0 Then
                        If Borc_Hesap = "" Then
                            Borc_Hesap = "-" & Bul.Offset(, -5)
                        Else
                            If InStr(1, Borc_Hesap, "-" & Bul.Offset(, -5)) = 0 Then
                                Borc_Hesap = Borc_Hesap & "-" & Bul.Offset(, -5)
                            End If
                        End If
                    Else
                        If Alacak_Hesap = "" Then
                            Alacak_Hesap = "-" & Bul.Offset(, -5)
                        Else
                            If InStr(1, Alacak_Hesap, "-" & Bul.Offset(, -5)) = 0 Then
                                Alacak_Hesap = Alacak_Hesap & "-" & Bul.Offset(, -5)
                            End If
                        End If
                    End If
                    Set Bul = S1.Range("F:F").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
       
        If Alacak_Hesap <> "" Then
            If S1.Cells(X, 8) > 0 Then S1.Cells(X, 13) = Mid(Alacak_Hesap, 2, Len(Alacak_Hesap) - 1)
        End If
                   
        If Borc_Hesap <> "" Then
            If S1.Cells(X, 9) > 0 Then S1.Cells(X, 13) = Mid(Borc_Hesap, 2, Len(Borc_Hesap) - 1)
        End If
        Borc_Hesap = ""
        Alacak_Hesap = ""
    Next

    Set Bul = Nothing
    Set S1 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Bey çok teşekkür ederim. Oldu yalnız ilk çalışmamdaki makro özellikleri gitti. Bütün hepsini bir makroda yapma şansımız var mı ?
Bir de son yaptığınız makroyu çalıştırmak için geliştiriciden visual basic yapıp, oradan da çalıştıra basıyorum. Bu şekilde çalıştırılıyor değil mi ?

Korhan Ayhan · 24 Kasım 2020

Bu kod ne aşamada devreye girecek?

Aşağıdaki satırı yazarak çalışmasını istediğiniz kodun içine entegre edebilirsiniz.

Call Module1.Karsi_Hesaplari_Listele

my_gan · 24 Kasım 2020

Korhan Ayhan' Alıntı:
Bu kod ne aşamada devreye girecek?

Aşağıdaki satırı yazarak çalışmasını istediğiniz kodun içine entegre edebilirsiniz.

Call Module1.Karsi_Hesaplari_Listele

Korhan Bey ilk başta BeforeDoubleClick'i silip yapıştırdığım için ilk baştaki özellikleri kaybetmiştim. Daha sonra BeforeDoubleClick'e dokunmadan yeni bir makro kaydederek istediğim sonuca ulaştım. Ama büyük verilerde makroyu çalıştırdığımda exceli kilitledi. Büyük verilerde bütün satırlara yapmak sorun olacak gibi. Acaba bu makroyu A Sütununda Filtre çalışırken işletebilme imkanımız var mı ? Bu sayede çok yüklenme olmaz diye düşünüyorum.

Korhan Ayhan · 25 Kasım 2020

Hız gerekiyorsa dizi yöntemini kullanmak gerekir.

Test edip süreyi bildirirseniz sevinirim.

C++:

Option Explicit

Sub Karsi_Hesaplari_Listele()
    Dim S1 As Worksheet, Dizi_Alacak As Object, Dizi_Borc As Object
    Dim Son As Long, Veri As Variant, X As Long
    Dim Say As Long, Say_A As Long, Say_B As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Muavin")
    Set Dizi_Alacak = CreateObject("Scripting.Dictionary")
    Set Dizi_Borc = CreateObject("Scripting.Dictionary")
    
    S1.Range("M2:M" & S1.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:L" & Son).Value
    
    ReDim Liste_Alacak(1 To S1.Rows.Count, 1 To 2)
    ReDim Liste_Borc(1 To S1.Rows.Count, 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 8) > 0 Then
            If Not Dizi_Alacak.Exists(Veri(X, 6)) Then
                Say_A = Say_A + 1
                Dizi_Alacak.Add Veri(X, 6), Say_A
                Liste_Alacak(Say_A, 1) = Veri(X, 6)
                Liste_Alacak(Say_A, 2) = Veri(X, 1)
            Else
                If InStr(1, Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2), Veri(X, 1)) = 0 Then
                    Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2) = Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2) & "-" & Veri(X, 1)
                End If
            End If
        End If
            
        If Veri(X, 9) > 0 Then
            If Not Dizi_Borc.Exists(Veri(X, 6)) Then
                Say_B = Say_B + 1
                Dizi_Borc.Add Veri(X, 6), Say_B
                Liste_Borc(Say_B, 1) = Veri(X, 6)
                Liste_Borc(Say_B, 2) = Veri(X, 1)
            Else
                If InStr(1, Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2), Veri(X, 1)) = 0 Then
                    Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2) = Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2) & "-" & Veri(X, 1)
                End If
            End If
        End If
    Next

    ReDim Liste(1 To S1.Rows.Count, 1 To 1)

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Veri(X, 8) > 0 Then
            If Dizi_Borc.Exists(Veri(X, 6)) Then
                Liste(Say, 1) = Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2)
            End If
        End If
        If Veri(X, 9) > 0 Then
            If Dizi_Alacak.Exists(Veri(X, 6)) Then
                Liste(Say, 1) = Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2)
            End If
        End If
    Next
    
    If Say > 0 Then S1.Range("M2").Resize(Say) = Liste
    
    Set S1 = Nothing
    Set Dizi_Alacak = Nothing
    Set Dizi_Borc = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

my_gan · 26 Kasım 2020

Korhan Ayhan' Alıntı:

Hız gerekiyorsa dizi yöntemini kullanmak gerekir.

Test edip süreyi bildirirseniz sevinirim.

C++:

Option Explicit

Sub Karsi_Hesaplari_Listele()
    Dim S1 As Worksheet, Dizi_Alacak As Object, Dizi_Borc As Object
    Dim Son As Long, Veri As Variant, X As Long
    Dim Say As Long, Say_A As Long, Say_B As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Muavin")
    Set Dizi_Alacak = CreateObject("Scripting.Dictionary")
    Set Dizi_Borc = CreateObject("Scripting.Dictionary")
   
    S1.Range("M2:M" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:L" & Son).Value
   
    ReDim Liste_Alacak(1 To S1.Rows.Count, 1 To 2)
    ReDim Liste_Borc(1 To S1.Rows.Count, 1 To 2)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 8) > 0 Then
            If Not Dizi_Alacak.Exists(Veri(X, 6)) Then
                Say_A = Say_A + 1
                Dizi_Alacak.Add Veri(X, 6), Say_A
                Liste_Alacak(Say_A, 1) = Veri(X, 6)
                Liste_Alacak(Say_A, 2) = Veri(X, 1)
            Else
                If InStr(1, Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2), Veri(X, 1)) = 0 Then
                    Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2) = Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2) & "-" & Veri(X, 1)
                End If
            End If
        End If
           
        If Veri(X, 9) > 0 Then
            If Not Dizi_Borc.Exists(Veri(X, 6)) Then
                Say_B = Say_B + 1
                Dizi_Borc.Add Veri(X, 6), Say_B
                Liste_Borc(Say_B, 1) = Veri(X, 6)
                Liste_Borc(Say_B, 2) = Veri(X, 1)
            Else
                If InStr(1, Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2), Veri(X, 1)) = 0 Then
                    Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2) = Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2) & "-" & Veri(X, 1)
                End If
            End If
        End If
    Next

    ReDim Liste(1 To S1.Rows.Count, 1 To 1)

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Veri(X, 8) > 0 Then
            If Dizi_Borc.Exists(Veri(X, 6)) Then
                Liste(Say, 1) = Liste_Borc(Dizi_Borc.Item(Veri(X, 6)), 2)
            End If
        End If
        If Veri(X, 9) > 0 Then
            If Dizi_Alacak.Exists(Veri(X, 6)) Then
                Liste(Say, 1) = Liste_Alacak(Dizi_Alacak.Item(Veri(X, 6)), 2)
            End If
        End If
    Next
   
    If Say > 0 Then S1.Range("M2").Resize(Say) = Liste
   
    Set S1 = Nothing
    Set Dizi_Alacak = Nothing
    Set Dizi_Borc = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan Bey bu şekilde baya hızlı oldu. 0,59 saniye çıktı. Diğerinde belki 20 dk filan yapmaya devam etmişti. Bunda baya hızlı. Çok teşekkür ederim.

Eğer Fonksiyonuna Benzer Makro

my_gan

İndir örnek çalışma

my_gan

Korhan Ayhan

Administrator

my_gan

Korhan Ayhan

Administrator

my_gan

Korhan Ayhan

Administrator

my_gan