• DİKKAT

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

Verileri süz, Her bir tipi ayrı göster..!

S

sensizsoldum

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhaba,
Ek dosya da gelenler sayfasında bir tipten onlarca giriş var. Bu girişlerden her bir tipi ana sayfada bir satıra gelecek şekilde, belirlenen verilerin getirilmesi gerekiyor.
Mesela: Gelenler sayfasında bulunan 8627 48 0 54 tip kodlu verinin, Ana sayfa dan dan tek bir satıra gelecek şekilde TİP KODU, hangi LKS olduğu, toplam METRE ve kaç adet olduklarının ANA SAYFA ya süzülmüş bir şekilde her bir tipi her bir satırda görmem gerekiyor. Örnek olarak ben ANA SAYFA ’ya 8627 48 0 54 tipini manuel olarak yazıyorum. Umarım açıklayıcı olmuşumdur. Ek dosyayı incelediğinizde eminim daha iyi anlayabileceğinizi düşünüyorum.
Gelenler sayfası na veri silinip yazılması çok yoğun olduğundan Makro bunu butonsuz, sayfaya her girişte güncellemesi gerekiyor. Bu çalışma daha önceden yapılmıştı. Arada baya farklılık olduğunda yeniden yapılandırılması gerekiyor.
İlgilenen arkadaşlara şimdiden çok teşekkür ederim.
İyi çalışmalar dilerim.

Saygılarımla.
 

Ekli dosyalar

Dosyanız ektedir.:cool:
Kod: 
Sub aktar59()
Dim sat As Long, sat2 As Long, sh As Worksheet
Sheets("ANA SAYFA").Select
Range("A3:D" & Rows.Count).Clear
Application.ScreenUpdating = False
Set sh = Sheets("GELENLER")
sat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat2 = 3
For i = 3 To sat1
    If WorksheetFunction.CountIf(sh.Range("A2:A" & i), sh.Cells(i, "A").Value) = 1 Then
        Cells(sat2, "A").Value = sh.Cells(i, "A").Value
        Cells(sat2, "B").Value = sh.Cells(i, "C").Value
        Cells(sat2, "C").Value = WorksheetFunction.SumIf(sh.Range("A2:A" & sat1), _
            sh.Cells(i, "A").Value, sh.Range("D2:D" & sat2))
        Cells(sat2, "D").Value = WorksheetFunction.SumIf(sh.Range("A2:A" & sat1), _
            sh.Cells(i, "A").Value, sh.Range("E2:E" & sat2))
        sat2 = sat2 + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName

    
End Sub
 

Ekli dosyalar

Merhaba
Evren Bey, ilginizden ötürü çok teşekkür ederim. Elinize sağlık. Son derece Başaralı ve hızlı.
TİP KODU, LKS ve Adetlerde sıkıntı yok. Metreler sadece 1 tanesinin metresini getiriyor. Örneğin yaptığınız örnekte en üstte 7343 06 1 var. Toplamda bunun metresi 2.137.5 olması gerekiyor. Oysa örnekte 150 görünüyor. Yani yazılan her tipinde ANA SAYFA ya o tipten ne kadar var ise toplam metreleri gelmesi gerekiyor. Bu makroyu yine bu hızda butonsuz olarak sayfaya her girişte yenilenmesini sağlaya bilir miyiz?
İlginizden dolayı tekrar teşekkür ederim.
Mutlu akşamlar dilerim.


Saygılarımla.
 
sensizsoldum' Alıntı:
Merhaba
Evren Bey, ilginizden ötürü çok teşekkür ederim. Elinize sağlık. Son derece Başaralı ve hızlı.
TİP KODU, LKS ve Adetlerde sıkıntı yok. Metreler sadece 1 tanesinin metresini getiriyor. Örneğin yaptığınız örnekte en üstte 7343 06 1 var. Toplamda bunun metresi 2.137.5 olması gerekiyor. Oysa örnekte 150 görünüyor. Yani yazılan her tipinde ANA SAYFA ya o tipten ne kadar var ise toplam metreleri gelmesi gerekiyor. Bu makroyu yine bu hızda butonsuz olarak sayfaya her girişte yenilenmesini sağlaya bilir miyiz?
İlginizden dolayı tekrar teşekkür ederim.
Mutlu akşamlar dilerim.


Saygılarımla.
Genişletmek için tıkla ...

dosyayı güncelledim.
2 nolu mesajdan indirebilirisniz.:cool:
 
Merhaba Evren Bey,
Bunun butonsuz olması daha önemli. Sayfaya girişte başlasa güncelleme. Çünkü Farklı sayfalar burdan veri çekecek. O bakımdan biraz önemli.

Teşekkür ederim İyi çalışmalar dilerim
 
sensizsoldum' Alıntı:
Merhaba Evren Bey,
Bunun butonsuz olması daha önemli. Sayfaya girişte başlasa güncelleme. Çünkü Farklı sayfalar burdan veri çekecek. O bakımdan biraz önemli.

Teşekkür ederim İyi çalışmalar dilerim
Genişletmek için tıkla ...

dosyayı 2 nolu mesajdan indirebilirisiniz.:cool:
 
Merhaba Evren Bey,
Çok teşekkür ederim sizleri yoruyorum ama aynı zamanda bizler için büyük bir kolaylık sağlıyorsunuz. Forumda emeği geçen herkese çok teşekkür ederim. Kodlarda sorun yok ve sürekli sonradan fark ettiğimiz bir şeyler çıkıyor. Sizden ricam bunu anlayışla karşılayın lütfen.
Kodlarınızın son hali aşağıdaki gibidir. Öncelikle sizden istirhamım bu kodların çalışmasını biraz daha hızlandırmak, örnekteki veri yaklaşık 2 bin kadar oysa gerçek çalışmada 10.000 kadar veri bulunuyor. Örnek çalışmada hız sorunu yok ama gerçek çalışmada 5 sn. kadar yavaşlama söz konusu. Birde ANA SAYFA A3:A aralığında yinelen koşul var. Sayfaya giriş çıkış yapıldığında yinelenen koşul devre dışı oluyor. Yukarı aşağı ve sağ soldan Ana Sayfayı ortalıyorum. Sayfaya giriş çıkış yapıldığında A3:D aralığı bu biçimlendirmeyi de yapmıyor.

Örnek çalışmanın son hali ekteki gibidir.

Mutlu akşamlar dilerim.

Saygılarımla.










Kod: 
Private Sub Worksheet_Activate()
Dim sat As Long, sat2 As Long, sh As Worksheet
Sheets("ANA SAYFA").Select
Range("A3:D" & Rows.Count).Clear
Application.ScreenUpdating = False
Set sh = Sheets("GELENLER")
sat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat2 = 3
For i = 3 To sat1
    If WorksheetFunction.CountIf(sh.Range("A2:A" & i), sh.Cells(i, "A").Value) = 1 Then
        Cells(sat2, "A").Value = sh.Cells(i, "A").Value
        Cells(sat2, "B").Value = sh.Cells(i, "C").Value
        Cells(sat2, "C").Value = WorksheetFunction.SumIf(sh.Range("A2:A" & sat1), _
            sh.Cells(i, "A").Value, sh.Range("D2:D" & sat2))
        Cells(sat2, "D").Value = WorksheetFunction.SumIf(sh.Range("A2:A" & sat1), _
            sh.Cells(i, "A").Value, sh.Range("E2:E" & sat2))
        sat2 = sat2 + 1
    End If
Next i
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

  • son.xls
    son.xls
    178 KB · Görüntüleme: 6
Kod: 
Birde ANA SAYFA A3:A aralığında yinelen koşul var. Sayfaya giriş çıkış yapıldığında yinelenen koşul devre dışı oluyor.
Yenilenen verilerde A sütununda yenilenen değerlerde.ayniveriden 1 tanesini ilk bulduğunu kaale alıp.oraya ilk bulduğu yenilenen veriyi yazıyor,ama toplamaı son satıra kadar yapıyor.Ben yenilenen veriyi a sütunu olarak yaptım.
Yoksa bir kolon değilde 2 kolon mu sorgulanacak?
 
5 sn normaldir .elbette 20 bin veride biraz daha ağırlaşacaktır.:cool:
Döngüde ufak bir müdahale yaptım. miktar hızlanma olmuştur.
 

Ekli dosyalar

Merhaba Evren Bey,
Hız konusu sanırsam iyileştirilmiş, Ek dosyayı kontrol edebilirmisiniz 3 tane açıklama da bulundum. umarım. açıklayıcı olmuşumdur.
 

Ekli dosyalar

sensizsoldum' Alıntı:
Merhaba Evren Bey,
Hız konusu sanırsam iyileştirilmiş, Ek dosyayı kontrol edebilirmisiniz 3 tane açıklama da bulundum. umarım. açıklayıcı olmuşumdur.
Genişletmek için tıkla ...
Şimdi bunlara bakacam.
Ama önce hız konusunu hallettim.Şimdi yolladığım dosyayı deneyin.:cool:
Kod: 
Option Base 1
Sub hizli59()
Dim sh As Worksheet, sat As Long, i As Long, liste, z As Object, myarr
Set sh = Sheets("GELENLER")
Sheets("ANA SAYFA").Select
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:D" & sat).ClearContents
Application.ScreenUpdating = False
If sat < 3 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = sh.Range("A3:E" & sat).Value
ReDim myarr(1 To 4, 1 To UBound(liste))
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 3)
    End If
    myarr(3, z.Item(liste(i, 1))) = myarr(3, z.Item(liste(i, 1))) + z.Item(liste(i, 1))
    myarr(4, z.Item(liste(i, 1))) = myarr(4, z.Item(liste(i, 1))) + liste(i, 5)
Next i
Erase liste: Set z = Nothing
ReDim Preserve myarr(1 To 4, 1 To n)
Range("A3").Resize(n, 4) = Application.Transpose(myarr)
Erase myarr
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Sanırım üstteki hatalı oldu.
Şimdi yolladığım dosyayı bakın.Hata kontrolunda yapın.
biçimlendirme olayıda tamamdır.:cool:
Yarın devam ederiz.Geç oldu.:cool:
Kod: 
Option Base 1
Sub hizli59()
Dim sh As Worksheet, sat As Long, i As Long, liste, z As Object, myarr
Set sh = Sheets("GELENLER")
Sheets("ANA SAYFA").Select
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:D" & sat).ClearContents
Application.ScreenUpdating = False
If sat < 3 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = sh.Range("A3:E" & sat).Value
ReDim myarr(1 To 4, 1 To UBound(liste))
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 3)
    End If
    myarr(3, z.Item(liste(i, 1))) = myarr(3, z.Item(liste(i, 1))) + liste(i, 4)
    myarr(4, z.Item(liste(i, 1))) = myarr(4, z.Item(liste(i, 1))) + liste(i, 5)
Next i
Erase liste: Set z = Nothing
ReDim Preserve myarr(1 To 4, 1 To n)
Range("A3").Resize(n, 4) = Application.Transpose(myarr)
Erase myarr
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Merhaba Evren Bey, Günaydın
İlginiz için çok teşekkür ederim istediğim gibi bir çalışma oldu. Elinize, bilginize sağlık.
Farklı bir konu daha açmıştım ANA SAYFA E3:E sütun aralığı ile alakalı. Aşağıdaki linkte konuya ulaşabilirsiniz gerekli açıklamaları da yaptım. Rica etsem bu konuya da ilgi gösterebilir misiniz? Hem kodların tek parça halinde olması benim içinde iyi olacak.

http://www.excel.web.tr/f48/listeye-yazylan-ye-il-listeye-ait-varsa-kyrmyzy-t124400.html

Tekrardan her şey için çok teşekkür ederim.

İyi çalışmalar dilerim.
 
Merhaba Evren Bey,
Kusura bakmayın sizi yoruyorum, ama 2 gündür uğraşıyorum yapamadım. Gelenler sayfasından ve Ana sayfadan METRE ve LKS sütunlarının yerleri değişmesi lazım. Çıldırma derecesine geldim lütfen yardımcı olurumsunuz.
Şimdiden çok teşekkür ederim.
 

Ekli dosyalar

sensizsoldum' Alıntı:
Merhaba Evren Bey,
Kusura bakmayın sizi yoruyorum, ama 2 gündür uğraşıyorum yapamadım. Gelenler sayfasından ve Ana sayfadan METRE ve LKS sütunlarının yerleri değişmesi lazım. Çıldırma derecesine geldim lütfen yardımcı olurumsunuz.
Şimdiden çok teşekkür ederim.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub hizli59()
Dim sh As Worksheet, sat As Long, i As Long, liste, z As Object, myarr
Set sh = Sheets("GELENLER")
Sheets("ANA SAYFA").Select
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:D" & sat).ClearContents
Application.ScreenUpdating = False
If sat < 3 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = sh.Range("A3:E" & sat).Value
ReDim myarr(1 To 4, 1 To UBound(liste))
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(1, n) = liste(i, 1)
        myarr(3, n) = liste(i, 4)
    End If
    myarr(2, z.Item(liste(i, 1))) = myarr(2, z.Item(liste(i, 1))) + liste(i, 3)
    myarr(4, z.Item(liste(i, 1))) = myarr(4, z.Item(liste(i, 1))) + liste(i, 5)
Next i
Erase liste: Set z = Nothing
ReDim Preserve myarr(1 To 4, 1 To n)
Range("A3").Resize(n, 4) = Application.Transpose(myarr)
Erase myarr
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Çok teşekkür ederim, Evren Bey,
Allah sizinde gönlünüze göre verir inşallah.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst