sayfa2 deki verileri bir kurala göre sayfa1 nasıl aktarılır?

[subutayı]

arkadaşlar,
elimde sayfa2 deki gibi 50000 bin adet veri var. Sayfa1 e bu verileri Aylık olarak belirli kurala göre aktarmak istiyorum. sayfa2 deki GRUP NO ve SIRA NO yu Sayfa1 e ataralım ama aynı tarihli GRUP NO ve SIRA NO varsa TEK bir tane olsun hangi tarih ise o tarih hücresine adeti kadar yazsın.
örneğin. GRUP NO su 3217 SIRA NO su 14 olan bir kişi 01.10.2016 tarihinde iki kez yazılmış. Bunu sayfa1 deki GRUP ve SIRA NO ya tek aktaracağız. ve sayfa1 deki 1 den 31 olan hücreler günleri ifade ediyor. Sayfa1 e grup no yu ve sıran noyu yazdırdıktan sonra 01.10.2016 tarihi onuncu ayın birini ifade ettiği için çizelgenin 1 yazan sütununa, GRUP ve SIRA NO su tek ise 1 yazsın. AYNI TARİHLİ mükerrer olan kaç tana varsa o rakamı yazsın.
Buradaki GRUP NO ve SIRA NO aynı olan bir kişiyi ifade ediyor. Tarihleri aynı ise mükerrer olacak. Grup No ile Sıra No aynı ay içinde 10 defada yazılabilir ama tarihleri bizim için önemli. aynı tarihli olanlanları mükerrer düşüneceğiz. ayrıca doldurulmuş örnek bir çizelge yide ekliyorum.
Yardımlarınızı bekliyorum. ilginize teşeküler.

 

[subutayı]

arkadaşlar,
yapılması mümkün değil mi? cevap veren olmadı arkadaşlar.

 

[subutayı]

konu güncel

 

[subutayı]

yardım lütfen

 

[Ziynettin]

Merhaba,
Ekli dosyanızın sayfa1 AJ2 hücresine ay, AK2 hücresine yıl yazın ve kodu çalıştırıp deneyiniz.

Option Explicit

Sub deneme()
Dim a(), b(), c(), d As Object, Krt As Variant
Dim S1 As Worksheet, S2 As Worksheet
Dim i As Long, Say As Long, Son As Long, X As Long, Y As Long
Dim Ay As Integer, Yil As Integer, t As Double, toplam As Double
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")

Ay = S1.[AJ2]
Yil = S1.[AK2]
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Son = S2.Range("A" & Rows.Count).End(3).Row
a = S2.Range("A2:C" & Son)
ReDim b(1 To UBound(a), 1 To 34)

For i = 1 To UBound(a)
    Krt = a(i, 1) & "|" & a(i, 2)
    If Month(a(i, 3)) = Ay And Year(a(i, 3)) = Yil Then
    If Not d.exists(Krt) Then
        Say = Say + 1
        d.Add Krt, Say
        b(Say, 1) = Yil
        b(Say, 2) = a(i, 1)
        b(Say, 3) = a(i, 2)
    End If
       
    For X = 1 To 31
    If Day(a(i, 3)) = X Then
        b(d.Item(Krt), X + 3) = b(d.Item(Krt), X + 3) + 1
    Else
        b(d.Item(Krt), X + 3) = b(d.Item(Krt), X + 3) + 0
    End If
    Next X
    End If
Next i
S1.Range("A3:AH" & Rows.Count).ClearContents
If Say > 0 Then
    S1.Range("A3").Resize(Say, 34) = b
End If
For Y = 4 To 34
    toplam = toplam + Application.Sum(Application.Index(b, , Y))
Next Y
Application.ScreenUpdating = True
MsgBox "Toplam Gün : " & toplam & vbLf & vbLf & "İşlem Süreniz : " & Format(Timer - t, "0.00") _
       & vbLf & vbLf & "İşleminiz Tamamlandı.", vbInformation
End Sub

 

[subutayı]

Sayın Ziynettin,
İlginize çok teşekkür ederim. sayfa2 de 58 kişi var ama günlerin içinin toplamını aldığım zaman 54 çıkıyor 4 kişi eksik görünüyor. sayfa2 e 10 cu ay listesinin tamamnı ekledim. 6774 kişi var kodu çalıştırdığım zaman ayın bütün günlerinin toplamı 1329 kişi gösteriyor halbuki 6774 olması gerikiyor. günlerdeki kişilerin toplamının grup no sayısını tutması gerekiyor.
ikinci konu. söküm sırası içine atılacak verilerimizi data diye bir excel dosyası oluşturup ordan söküm sırasının içine göndersek. her iki excel dosyasını da söküm diye bir klasöriçine atabiliriz. böyle daha sağlıklı olacak. saygılar...

 

[Korhan Ayhan]

Lütfen konu başlığınızı forum kurallarına uygun olarak düzeltir misiniz?

 

[Ziynettin]

Sayın subutayı konu başlığını sorunuza uygun olarak değiştiriniz.

#5 nolu mesajı tekrar deneyiniz.

 

[subutayı]

sayın Ziynettin,
ilginiz için teşekürler. iyi ki varsınız. #6 nolu mesajda belirttiğim gibi aktarma işlemini data diye bir dosya açıp söküm sırası dosyasına göndermemiz mümkün değil mi. söküm sırası dosyasını bir programın içine çekeceğim, içindeki macro kodlarından dolayı sorun çikarabilir.
tekrar teşekürler.

 

[Ziynettin]

Dosyalar arasında aktarma hakkında fazla bilgim yok. Umarım uyarlayan arkadaşlar olur.

 

[subutayı]

eyvallah üstadım, bunu yarın denerim. inşallah sorun çıkmaz. 9 uncu mesajdaki gibi yardımcı olan olursa makbule geçer.

 

[subutayı]

sorunumu çözen Sayın Ziynettin ve ilgilenin bütün arkadaşlara teşekkür ederim. istediğim gibi oldu. sağ olun.