2 Tarih arası Alınanları Listelemek

1Al2Ver · 19 Mart 2021

Merhaba,

Ön Bilgi ; 2 Tarih Arasında olan Tedarikçilere ait toplam parasal tutarları, başka bir sayfada çizelge halinde almak istiyorum,

İşleyiş ; Aynı Fatura, Aynı Gün ve Aynı Tedarikçi olanlar tek sayılıp, alınanların toplamını bir satıra,

Farklı Fatura, Farklı Gün ve Farklı Tedarikçiyi de bir satıra alarak oluşan bir çizelge düşündüm,

Ek'li dosyada örneklediğim ve açıkladığım şekliyle olmasını arzuluyorum,

Veri alınan sayfa satır sayımız yaklaşık 12.000 dir,

Teşekkür ederim.

Korhan Ayhan · 19 Mart 2021

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Tarih1 As Date, Tarih2 As Date, Veri As Variant
    Dim Say As Long, Son As Long, X As Long
    Dim Aranan As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Set S1 = Sheets("MALZEME_GİRİŞ_ÇİZELGESİ")
    Set S2 = Sheets("GİDERLER_RAPOR")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Tarih1 = S2.Range("J1").Value
    Tarih2 = S2.Range("J2").Value
    
    S2.Range("A4:E" & S2.Rows.Count).Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("B2:K" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 5)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) >= Tarih1 And Veri(X, 1) <= Tarih2 Then
            If Veri(X, 2) <> "DEPO FAZLASI" Then
                Aranan = Veri(X, 1) & "|" & Veri(X, 2) & "|" & Veri(X, 10)
                If Not Dizi.Exists(Aranan) Then
                    Say = Say + 1
                    Dizi.Add Aranan, Say
                    Liste(Say, 1) = Say
                    Liste(Say, 2) = Veri(X, 1)
                    Liste(Say, 3) = Veri(X, 2)
                    Liste(Say, 4) = Veri(X, 10)
                    Liste(Say, 5) = Veri(X, 9)
                Else
                    Liste(Dizi.Item(Aranan), 5) = Liste(Dizi.Item(Aranan), 5) + Veri(X, 9)
                End If
            End If
        End If
    Next
    
    If Say > 0 Then
        With S2.Range("A4").Resize(Say, 5)
            .Value = Liste
            .Borders.LineStyle = 1
        End With
        S2.Columns.AutoFit
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

1Al2Ver · 19 Mart 2021

Sayın Korhan Ayhan merhaba,

Öncelikle size, her şey için çok teşekkür etmek istiyorum, sağ olun,

İki konu dışında mükemmel çalışıyor ve mevcut verileri almak, 2 sn. sürüyor,

1) Alınan veriler, 04:52 satır arası 1 nci sayfaya, 60 ncı satır ve yukarısı 2 nci sayfaya gelsin arzulamıştım,

2) "MALZEME_GİRİŞ_ÇİZELGESİ" sayfasında mevcut listede, DEPO FAZLASI yazan satırlar, aktarılan sayfada ("GİDERLER_RAPOR") oluşan çizelgede yer almayacak,

Zahmet olmayacak ise, kodda gerekli düzenlemeyi yapmanızı rica edebilir miyim ?

Teşekkür ederim.

Korhan Ayhan · 20 Mart 2021

DEPO FAZLASI kriteri için koda sorgu satırı ekledim. Son halini deneyebilirsiniz.

Sayfa ayarını kod içinde yapmak zaman kaybına yol açacaktır.

1.-2.-3. satırları yazdırma ayarlarından "Üstte yinelenecek satırlar" seçeneğini kullanarak her sayfada görünmesini sağlayabilirsiniz.

1Al2Ver · 20 Mart 2021

Sayın Korhan Ayhan tekrar merhaba,

Emek ve bilgilendirmeler için çok teşekkür ederim,

Saygılarımla.

1Al2Ver · 20 Mart 2021

Tekrar merhaba,

Çizelgeye,

1) Çizelgenin son sıra no.sunu sayı ve yazı ile kalın yazan ( ////////YALNIZ 63 (ALTMIŞÜÇ) KALEMDİR.////////) bir satır,

2) "E" sütunundaki sayıları ve toplamını kalın ve para birimi ( örn ; 123.130,00 TL ) olarak yazan,

ilavelere ihtiyacım oldu,

Mevcut kodda gerekli düzenlemeleri rica ediyorum,

Teşekkür ederim.

1Al2Ver · 20 Mart 2021

Merhaba,

İlgili dosyadaki kodda küçük bir düzeltme rica edebilir miyim ?

Yazıların font büyüklüğünü 1 tık düşürmek istiyorum, nasıl bir düzenleme yapmalıyım ?

Teşekkür ederim.

Korhan Ayhan · 20 Mart 2021

Bu küçük düzeltmeleri MAKRO KAYDET yöntemini kullanarak kendinizde kolaylıkla uygulayabilirsiniz.

1Al2Ver · 21 Mart 2021

Sayın Korhan Ayhan merhaba,

Öneriniz için teşekkür ederim,

Saygılarımla.

sokrates11 · 21 Mart 2021

Merhabalar Ustalar:
Bu forumda paylaşılan VBA kodlarıu ile; "StokHareketleri" tablosundaki iki tarih aralığında aynı "Ürün Kodu"'na sahip olan ürünleri toplatarak, ilgili tarih aralığında Giren-Çıkan>0 olanları (F; sütunu Giren; G; sütunu Çıkan) ("DevirRapor") sayfasında rapor oluşturmak istiyorum.

*** Aşağıdaki kodlarda sıfır olanlara "-" işareti koydurdum. Bu satırların hiç olmamasını nasıl yapabiliriz.
Yardımlarınızı bekliyorum.

C++:

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Tarih1 As Date, Tarih2 As Date, Veri As Variant
    Dim Say As Long, Son As Long, X As Long
    Dim Aranan As String, Zaman As Double
   
    On Error GoTo ExitProc:
   
      Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
      
    Set S1 = Sheets("[B]StokHareketleri[/B]")
    Set S2 = Sheets("[B]DevirRapor[/B]")
   
   
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Tarih1 = S2.Range("C2").Value
    Tarih2 = S2.Range("C4").Value
   
    
    S2.Range("A7:H" & S2.Rows.Count).Clear
   
       
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row

    If Son < 3 Then Son = 3
   
    Veri = S1.Range("A2:G" & Son).Value
       
    ReDim Liste(1 To UBound(Veri, 1), 1 To 8)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
   
If Veri(X, 7) >= Tarih1 And Veri(X, 7) <= Tarih2 Then
Aranan = Veri(X, 2)
           
          
              If Not Dizi.Exists(Aranan) Then
             
                    Say = Say + 1
                    Dizi.Add Aranan, Say
           
                    Liste(Say, 1) = Say
                    Liste(Say, 2) = Veri(X, 1)
                    Liste(Say, 3) = Veri(X, 2)
                    Liste(Say, 4) = Veri(X, 3)
                    Liste(Say, 5) = Veri(X, 4)
                    Liste(Say, 6) = Veri(X, 5)
                    Liste(Say, 7) = Veri(X, 6)
                   
                    If Liste(Say, 6) - Liste(Say, 7) > 0 Then
                    Liste(Say, 8) = Liste(Say, 6) - Liste(Say, 7)
                    End If
            
               
                Else
      
                                 
                    Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 5)
                    Liste(Dizi.Item(Aranan), 7) = Liste(Dizi.Item(Aranan), 7) + Veri(X, 6)
                   
                                      
                   If Liste(Dizi.Item(Aranan), 6) - Liste(Dizi.Item(Aranan), 7) > 0 Then
                    Liste(Dizi.Item(Aranan), 8) = Liste(Dizi.Item(Aranan), 6) - Liste(Dizi.Item(Aranan), 7)
                Else
                     Liste(Dizi.Item(Aranan), 8) = "-"
                    
                    End If
                   
                      
                  
                  
                End If
            End If
    Next
   
                   
    If Say > 0 Then
        With S2.Range("A7").Resize(Say, 8)
            .Value = Liste
            .Borders.LineStyle = 1
                      
           
        End With
    
  
        S2.Columns.AutoFit
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
      
MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "Girdiğiniz tarih aralığında ygun kayıt bulunamadı!", vbExclamation
    End If



i = S2.Range("B6").End(xlDown).Row

Sheets("DevirRapor").Select

Sheets("DevirRapor").Range("B6:I" & i).Select
    S2.Sort.SortFields.Clear
  S2.Sort.SortFields.Add Key:=Range( _
        "B6:B" & i), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With S2.Sort
        .SetRange Range("B6:I" & i)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
       
       
       
    End With


Sheets("DevirRapor").Select
   
Sheets("DevirRapor").Columns("F:H").Select
    Selection.NumberFormat = "0.0"
   Selection.NumberFormat = "0.00"
    Selection.NumberFormat = "0.000"
   
Sheets("DevirRapor").Range("A1").Select
  
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
   
   Exit Sub
ExitProc:
MsgBox "Tarih Bilgisini Kontrol Ediniz!...", vbCritical, "Uyarı"
 
End Sub

Korhan Ayhan · 21 Mart 2021

Merhaba,

Forumda kod paylaşırken lütfen CODE tagını kullanınız. Daha düzenli ve okunaklı görünecektir. Bu işlem için mesaj yazdığınız pencerede bulunan 3 nokta (...) sembolüne tıklayıp kodları açılan pencereye yapıştırmanız yeterlidir.

sokrates11 · 21 Mart 2021

Korhan Ayhan' Alıntı:
Merhaba,

Forumda kod paylaşırken lütfen CODE tagını kullanınız. Daha düzenli ve okunaklı görünecektir. Bu işlem için mesaj yazdığınız pencerede bulunan 3 nokta (...) sembolüne tıklayıp kodları açılan pencereye yapıştırmanız yeterlidir.

Kusura bakmayın Korhan Bey. Bir dahaki sefere dikkat edeceğim. Şimdi düzenleyecektim ancak, Düzenleme seçeneğini bulamadım.

Korhan Ayhan · 21 Mart 2021

Ben düzenledim..

Küçük bir örnek dosya paylaşırsanız kodları üzerinden düzenleyelim.

sokrates11 · 21 Mart 2021

Korhan Ayhan' Alıntı:
Ben düzenledim..

Küçük bir örnek dosya paylaşırsanız kodları üzerinden düzenleyelim.

Örnek Dosyayı aşağıdaki linkten indirebilirsiniz.
Çok teşekkür ederim.

İndir Stok Rapor

Dosyayı indir Stok Rapor

dosya.co

Korhan Ayhan · 21 Mart 2021

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Tarih1 As Date, Tarih2 As Date, Veri As Variant
    Dim Say As Long, Son As Long, X As Long
    Dim Aranan As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
       
    Set S1 = Sheets("StokHareketleri")
    Set S2 = Sheets("DevirRapor")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Tarih1 = S2.Range("C2").Value
    Tarih2 = S2.Range("C4").Value
    
    If Val(Tarih1) = 0 Or Val(Tarih2) = 0 Then
        MsgBox "Tarih bilgisini kontrol ediniz!", vbCritical, "Uyarı"
        GoTo 10
    End If
    
    S2.Range("A7:H" & S2.Rows.Count).Clear
        
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("A2:G" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 8)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 7) >= Tarih1 And Veri(X, 7) <= Tarih2 Then
            Aranan = Veri(X, 2)
            If Not Dizi.Exists(Aranan) Then
                Say = Say + 1
                Dizi.Add Aranan, Say
        
                Liste(Say, 1) = Say
                Liste(Say, 2) = Veri(X, 1)
                Liste(Say, 3) = Veri(X, 2)
                Liste(Say, 4) = Veri(X, 3)
                Liste(Say, 5) = Veri(X, 4)
                Liste(Say, 6) = Veri(X, 5)
                Liste(Say, 7) = Veri(X, 6)
                Liste(Say, 8) = Liste(Say, 6) - Liste(Say, 7)
            Else
                Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 5)
                Liste(Dizi.Item(Aranan), 7) = Liste(Dizi.Item(Aranan), 7) + Veri(X, 6)
                Liste(Dizi.Item(Aranan), 8) = Liste(Dizi.Item(Aranan), 6) - Liste(Dizi.Item(Aranan), 7)
            End If
        End If
    Next
                        
    Say = 0
                        
    ReDim Son_Liste(1 To UBound(Liste, 1), 1 To UBound(Liste, 2))
                        
    For X = LBound(Liste, 1) To UBound(Liste, 1)
        If Liste(X, 8) <> 0 Then
            Say = Say + 1
            Son_Liste(Say, 1) = Say
            Son_Liste(Say, 2) = Liste(X, 2)
            Son_Liste(Say, 3) = Liste(X, 3)
            Son_Liste(Say, 4) = Liste(X, 4)
            Son_Liste(Say, 5) = Liste(X, 5)
            Son_Liste(Say, 6) = Liste(X, 6)
            Son_Liste(Say, 7) = Liste(X, 7)
            Son_Liste(Say, 8) = Liste(X, 8)
        End If
    Next
    
    If Say > 0 Then
        With S2.Range("A7").Resize(Say, 8)
            .Value = Son_Liste
            .Borders.LineStyle = 1
        End With
        
        S2.Range("F7:H" & S2.Rows.Count).NumberFormat = "0.000"
        S2.Range("B7:H" & S2.Rows.Count).Sort S2.Range("B7"), xlAscending, , , , , , xlNo
        S2.Columns.AutoFit
        
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "Girdiğiniz tarih aralığında uygun kayıt bulunamadı!", vbExclamation
    End If
    
10  Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

sokrates11 · 21 Mart 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Tarih1 As Date, Tarih2 As Date, Veri As Variant
    Dim Say As Long, Son As Long, X As Long
    Dim Aranan As String, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
      
    Set S1 = Sheets("StokHareketleri")
    Set S2 = Sheets("DevirRapor")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Tarih1 = S2.Range("C2").Value
    Tarih2 = S2.Range("C4").Value
   
    If Val(Tarih1) = 0 Or Val(Tarih2) = 0 Then
        MsgBox "Tarih bilgisini kontrol ediniz!", vbCritical, "Uyarı"
        GoTo 10
    End If
   
    S2.Range("A7:H" & S2.Rows.Count).Clear
       
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 3 Then Son = 3
   
    Veri = S1.Range("A2:G" & Son).Value
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 8)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 7) >= Tarih1 And Veri(X, 7) <= Tarih2 Then
            Aranan = Veri(X, 2)
            If Not Dizi.Exists(Aranan) Then
                Say = Say + 1
                Dizi.Add Aranan, Say
       
                Liste(Say, 1) = Say
                Liste(Say, 2) = Veri(X, 1)
                Liste(Say, 3) = Veri(X, 2)
                Liste(Say, 4) = Veri(X, 3)
                Liste(Say, 5) = Veri(X, 4)
                Liste(Say, 6) = Veri(X, 5)
                Liste(Say, 7) = Veri(X, 6)
                Liste(Say, 8) = Liste(Say, 6) - Liste(Say, 7)
            Else
                Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 5)
                Liste(Dizi.Item(Aranan), 7) = Liste(Dizi.Item(Aranan), 7) + Veri(X, 6)
                Liste(Dizi.Item(Aranan), 8) = Liste(Dizi.Item(Aranan), 6) - Liste(Dizi.Item(Aranan), 7)
            End If
        End If
    Next
                       
    Say = 0
                       
    ReDim Son_Liste(1 To UBound(Liste, 1), 1 To UBound(Liste, 2))
                       
    For X = LBound(Liste, 1) To UBound(Liste, 1)
        If Liste(X, 8) <> 0 Then
            Say = Say + 1
            Son_Liste(Say, 1) = Say
            Son_Liste(Say, 2) = Liste(X, 2)
            Son_Liste(Say, 3) = Liste(X, 3)
            Son_Liste(Say, 4) = Liste(X, 4)
            Son_Liste(Say, 5) = Liste(X, 5)
            Son_Liste(Say, 6) = Liste(X, 6)
            Son_Liste(Say, 7) = Liste(X, 7)
            Son_Liste(Say, 8) = Liste(X, 8)
        End If
    Next
   
    If Say > 0 Then
        With S2.Range("A7").Resize(Say, 8)
            .Value = Son_Liste
            .Borders.LineStyle = 1
        End With
       
        S2.Range("F7:H" & S2.Rows.Count).NumberFormat = "0.000"
        S2.Range("B7:H" & S2.Rows.Count).Sort S2.Range("B7"), xlAscending, , , , , , xlNo
        S2.Columns.AutoFit
       
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = 1
        Application.Calculation = -4105
        MsgBox "Girdiğiniz tarih aralığında uygun kayıt bulunamadı!", vbExclamation
    End If
   
10  Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

Çook teşekkür ederim Korhan bey. Tam düşündüğüm gibi olmuş.
Elinize sağlık.

2 Tarih arası Alınanları Listelemek

1Al2Ver

Ekli dosyalar

Korhan Ayhan

Administrator

1Al2Ver

Korhan Ayhan

Administrator

1Al2Ver

1Al2Ver

Ekli dosyalar

1Al2Ver

Korhan Ayhan

Administrator

1Al2Ver

sokrates11

Korhan Ayhan

Administrator

sokrates11

Korhan Ayhan

Administrator

sokrates11

İndir Stok Rapor

Korhan Ayhan

Administrator

sokrates11