• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tarihe Göre Veri Çekmek..!

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhabalar,
Kontrol sayfasına her girişte güncel bilgileri gösterecek makroya ihtiyacım var,
Hangi tarihte, hangi tipten,(tip adı da gelecek) kaç metre kumaş ve ne kadar kilo geldiğinin toplamını almak istiyorum.
İlk önce temel alınacak bilgi Tarih, Herhangi bir tarihte birden fazla tip gelebiliyor. Daha sonra tip kodu( tip adı) yani tarihe göre listeleme yapması gerekiyor.
Örnek olarak ben manuel olarak birkaç tip yaptım. Bunu makro ile sayfaya her girişte görmek istiyorum. Konu hakkında yardımcı olursanız sevinirim. Şirkette olduğum örnek dosyayı link olarak paylaşıyorum. Akşam örnek dosya olarak ekleyebilirim.
 

Ekli dosyalar

Dosyanız ektedir.:cool:

Kod:
Option Base 1
Sub gelengiden59(ByVal sh As Worksheet)
Dim z As Object, sat As Long, i As Long, n As Long
Dim liste(), myarr(), k As Range
Sheets("KONTROL").Select
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row
[B][COLOR="Red"]If sat < 3 Then Exit Sub[/COLOR][/B]
liste = sh.Range("A3:H" & sat).Value
sat = UBound(liste)
ReDim myarr(5, sat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To sat
    If Not z.exists(liste(i, 1) & liste(i, 2)) Then
        n = n + 1
        z.Add liste(i, 1) & liste(i, 2), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
    End If
    myarr(4, z.Item(liste(i, 1) & liste(i, 2))) = _
            myarr(4, z.Item(liste(i, 1) & liste(i, 2))) + liste(i, 7)
    myarr(5, z.Item(liste(i, 1) & liste(i, 2))) = _
            myarr(5, z.Item(liste(i, 1) & liste(i, 2))) + liste(i, 8)
Next i
If sh.Name = "GİDEN" Then
        Set k = Range("A3")
    ElseIf sh.Name = "GELEN" Then
        Set k = Range("G3")
End If
Erase liste
Set z = Nothing
If UBound(myarr, 2) > 0 Then ReDim Preserve myarr(1 To 5, 1 To n)
Application.ScreenUpdating = False
If n > 0 Then
    k.Resize(n, 5) = Application.Transpose(myarr)
End If
Erase myarr
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Merhaba Evren Hocam,
Çalışma çok süper olmuş elinize sağlık. Konuyu net olarak anladığınızı umarak. Metre ve Kg toplamlarında sıkıntı var. Kontrol ettiğimde doğru sonuçları vermiyor.
Tekrardan göz atabilirmisiniz.
İyi akşamlar dilerim.
 
Merhaba Evren Hocam,
Çalışma çok süper olmuş elinize sağlık. Konuyu net olarak anladığınızı umarak. Metre ve Kg toplamlarında sıkıntı var. Kontrol ettiğimde doğru sonuçları vermiyor.
Tekrardan göz atabilirmisiniz.
İyi akşamlar dilerim.
Dosyayı güncelledim.
2 nolu mesajdan dosyanızı indirebilirsiniz.:cool:
 
Merhaba Hocam,
Günaydın Hayırlı Sabahlar, Yazdığınız kodlar on numara olmuş. Elinize, bilginize sağlık. Kontrolleri
edince minik bir sorunla karşılaştım. Buna sorun denmez ama bilmiyorum sizde fark ettiniz mi. gelen ve giden sayfalarında 3 ve sonrasında veri olmayınca, başlıkları çekiyor. Kodlarınız diğer kodlardan çok farklı uyarlamaya çalışıyorum ama olmadı. Bu kontrolleri de sağlarsanız çok sevinirim.

Tekrardan çok teşekkür ederim iyi ki varsınız.

İyi çalışmalar dilerim.
 
Kodlarınız diğer kodlardan çok farklı uyarlamaya çalışıyorum ama olmadı.
Kodların hızlı çalışması için bu kodlamayı tercih ettim.
dosyayı güncelledim.
2 nolu mesajdan indirebilirisiniz.:cool:
 
Geri
Üst