Ay Adına Göre Diğer Sayfalardan Veri Almak

[1Al2Ver]

Merhaba,

"Aylık Hesaplama" sayfasında, "B1" Veri Doğrulama ile seçilen aya ait Giriş-Çıkış'ları, "D4:I3000" sütunlarına, Topla.Çarpım ile almaktayım.

Bu İşlemin makro ile gerçekleşmesi için bu sayfanın koduna bir kod yazmaya çalıştım, ancak verileri getiremedim, belli ki temel bir hata yapıyorum,

Ricam, kayıtlı makroda düzeltme yapılmasıdır.

Teşekkür ederim.

Sub HESAPLA()

    Dim i As Long
    
    Sheets("AYLIK_HESAPLAMA").Select
    
    Range("D4:I" & Rows.Count).ClearContents
    
    For i = 4 To Cells(Rows.Count, "b").End(xlUp).Row
  
        
        Cells(i, "D") = Evaluate("=SUMPRODUCT((MALZEME_GİRİŞİ!d2:d3000=" & Cells(i, "b").Address() & ")" & _
            "*(TEXT(MALZEME_GİRİŞİ!b2:b3000,""mmmm"")=B1)*(MALZEME_GİRİŞİ!d2:d3000=B4)*(MALZEME_GİRİŞİ!F2:F3000))")
            
        Cells(i, "E") = Evaluate("=SUMPRODUCT((MALZEME_GİRİŞİ!d2:d3000=" & Cells(i, "b").Address() & ")" & _
            "*(TEXT(MALZEME_GİRİŞİ!b2:b3000,""mmmm"")=B1)*(MALZEME_GİRİŞİ!d2:d3000=B4)*(MALZEME_GİRİŞİ!H2:H3000))")
            
        'Cells(i, "F") = Cells(i, "E") / Cells(i, "D") 'GİRİŞ - Ortalamayı yani E sütununu hesaplıyor...
        
                      
        Cells(i, "G") = Evaluate("=SUMPRODUCT((MALZEME_ÇIKIŞI!b2:b3000=" & Cells(i, "b").Address() & ")" & _
            "*(TEXT(MALZEME_ÇIKIŞI!a2:a3000,""mmmm"")=B1)*(MALZEME_ÇIKIŞI!b2:b3000=B4)*(MALZEME_ÇIKIŞI!D2:D3000))")
            
        Cells(i, "H") = Evaluate("=SUMPRODUCT((MALZEME_ÇIKIŞI!b2:b3000=" & Cells(i, "b").Address() & ")" & _
            "*(TEXT(MALZEME_ÇIKIŞI!a2:a3000,""mmmm"")=B1)*(MALZEME_ÇIKIŞI!b2:b3000=B4)*(MALZEME_ÇIKIŞI!F2:F3000))")
            
        'Cells(i, "I") = Cells(i, "H") / Cells(i, "G") 'ÇIKIŞ - Ortalamayı yani I sütununu hesaplıyor...
            
              
        Next i
End Sub

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.
Not: Kodlarınızı tamamen değiştirdim.

 

[1Al2Ver]

Sayın muygun merhaba,

İlginiz, güzel çözümünüz ve emeğiniz için teşekkür ederim,

Toplam Girişlerde hatalı toplam var,

Ekmek için Şubat ayında giriş miktarı ; 7564 adet ve Tutarı ; 69,210.60 TL olmalı

Kontrol ederseniz memnun olurum.

 

[1Al2Ver]

Sayın muygun,

Açıklamalı dosyam ek'tedir,

Teşekkür ederim.

 

[muygun]

Merhaba;
Haklısınız. Galiba şimdi düzeldi.
Eki deneyin.
İyi çalışmalar.

 

[Korhan Ayhan]

Kendi kullandığınız yöntemi aşağıdaki gibi uygulayabilirsiniz.

Sizin uyguladığınız tekniğe göre işlemi kod ile yapacaksanız en hantal yöntemi tercih etmiş oluyorsunuz. Çünkü TOPLA.ÇARPIM işin içine koşullar girdiğinde oldukça yavaş çalışan bir fonksiyondur. Bunun yerine ÇOKETOPLA fonksiyonunu kullanabilirsiniz. Ek olarak TARİH verisi içeren bir tabloda sadece AY bilgisini kullanmak sorun yaratacaktır. Bence ay-yıl bilgisini kullanmak daha doğru sonuçlar verecektir.

Ama siz zaten işlemi makro ile yapmaya karar verdiğiniz için ADO ya da Dictionary gibi çok hızlı sonuç veren yöntemleri tercih edebilirsiniz. Bildiğiniz üzere bunlarla ilgili forumda bolca örnek paylaşıldı. Kodları inceleyip dosyanıza uyarlamaya çalışabilirsiniz.


Not : Bilgisayarımdaki Türkçe karakter sorunu nedeniyle sayfa isimlerinizi değiştirmek durumunda kaldım. Siz kendi dosyanıza göre revize edersiniz.

Sub Rapor()
    Application.ScreenUpdating = False
  
    With Sheets("Rapor")
        .Range("D4:I52").ClearContents
        .Range("D4:D52").Formula = "=SUMPRODUCT((TEXT(Malzeme_Girisi!$B$2:$B$3000,""aaaa"")=$B$1)*(Malzeme_Girisi!$D$2:$D$3000=$B4)*(Malzeme_Girisi!$F$2:$F$3000))"
        .Range("E4:E52").Formula = "=SUMPRODUCT((TEXT(Malzeme_Girisi!$B$2:$B$3000,""aaaa"")=$B$1)*(Malzeme_Girisi!$D$2:$D$3000=$B4)*(Malzeme_Girisi!$H$2:$H$3000))"
        .Range("F4:F52").Formula = "=IFERROR(E4/D4,)"
        .Range("D4:F52").Value = .Range("D4:F52").Value
  
        .Range("G4:G52").Formula = "=SUMPRODUCT((TEXT(Malzeme_Cikisi!$A$2:$A$3000,""aaaa"")=$B$1)*(Malzeme_Cikisi!$B$2:$B$3000=$B4)*(Malzeme_Cikisi!$D$2:$D$3000))"
        .Range("H4:H52").Formula = "=SUMPRODUCT((TEXT(Malzeme_Cikisi!$A$2:$A$3000,""aaaa"")=$B$1)*(Malzeme_Cikisi!$B$2:$B$3000=$B4)*(Malzeme_Cikisi!$F$2:$F$3000))"
        .Range("I4:I52").Formula = "=IFERROR(H4/G4,)"
        .Range("G4:I52").Value = .Range("G4:I52").Value
    End With
  
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[1Al2Ver]

Sayın muygun tekrar merhaba,

Evet düzeldi, teşekkür ederim.

Saygılarımla.

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Açıklamalar ve çözüm için teşekkür ederim,

Arşivimde Topla.Çarpım çözümlü onlarca dosya var, bunları formül yoğunluğundan kurtarmak için makro ile düzenlemeye çalışıyorum,

Bu nedenle, mevcut en yeni dosyadan yola çıkarak bir örnek çözüm elde etmek istedim,

Sayın muygun ve siz, örnek çözümler sundunuz, sağ olun, zaman yaratarak, bunlar üzerinden ve önerdiğiniz ADO ve Dictionary yöntemlerini inceleyerek ilerleme kaydetmek istiyorum.

Tekrar teşekkür ederim,

Saygılarımla.

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Dim veri, ay, i, urun, say, data, sira

    With Sheets("AYLIK_HESAPLAMA")
        ay = Month(DateValue("01 " & .Range("B1").Value & " " & Year(Date)))
        With .Range("b4:I" & Rows.Count)
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
    End With

    With CreateObject("Scripting.Dictionary")
        With Sheets("MALZEME_GİRİŞİ")
            veri = .Range("B2:H" & .Cells(Rows.Count, 2).End(3).Row).Value
            ReDim data(1 To 2 * UBound(veri), 1 To 8)
        End With

        For i = 1 To UBound(veri)
            If Month(veri(i, 1)) = ay Then
                urun = veri(i, 3) & "|" & veri(i, 4)
                If Not .exists(urun) Then
                    say = say + 1
                    data(say, 1) = veri(i, 3)
                    data(say, 2) = veri(i, 4)
                    data(say, 3) = veri(i, 5)
                    data(say, 4) = veri(i, 7)
                    .Item(urun) = say
                Else
                    sira = .Item(urun)
                    data(sira, 3) = data(sira, 3) + veri(i, 5)
                    data(sira, 4) = data(sira, 4) + veri(i, 7)
                End If
            End If
        Next i

        With Sheets("MALZEME_ÇIKIŞI")
            veri = .Range("A2:F" & .Cells(Rows.Count, 2).End(3).Row).Value
        End With

        For i = 1 To UBound(veri)
            If Month(veri(i, 1)) = ay Then
                urun = veri(i, 2) & "|" & veri(i, 3)
                If Not .exists(urun) Then
                    say = say + 1
                    data(say, 1) = veri(i, 2)
                    data(say, 2) = veri(i, 3)
                    data(say, 6) = veri(i, 4)
                    data(say, 7) = veri(i, 6)
                    .Item(urun) = say
                Else
                    sira = .Item(urun)
                    data(sira, 6) = data(sira, 6) + veri(i, 4)
                    data(sira, 7) = data(sira, 7) + veri(i, 6)
                End If
            End If
        Next i
    End With

    For i = 1 To say
        If data(i, 3) <> 0 Then data(i, 5) = data(i, 4) / data(i, 3)
        If data(i, 6) <> 0 Then data(i, 8) = data(i, 7) / data(i, 6)
    Next i

    With Sheets("AYLIK_HESAPLAMA")
        With .Range("B4").Resize(say, 8)
            .Value = data
            .Borders.LineStyle = xlContinuous
            .Sort .Cells(1), xlAscending, , , , , , xlNo
        End With
    End With

    Application.ScreenUpdating = True
    MsgBox "İşlem TAMAM.", vbInformation

End Sub

 

[1Al2Ver]

Sayın veyselemre merhaba,

İlginiz ve alternatif kod için teşekkür ederim, sağ olun,

Bu ve diğer kodlar üzerine çalışıp, mantığını kavrayıp, datası uzun formüllü dosyaları makro ile yeniden hayata geçirmeyi arzuluyorum,

Umarım başarılı olurum.

Saygılarımla.