Tarihe ve sicile göre veri aktarma

[zehfeysal]

sicil tarih ve toplam hanesi içeren sütunlar var veri sayfasında. Buradaki toplam hanesindeki bilgiyi ilgili sicil ve tarihin olduğu liste sayfasına aktarmak istiyorum. Liste sayfası en az bir yıllık veriyi toplamalı.

Ben bunu formülle yapmaya çalıştım. İşimi de gördü. Ancak sayfa kastı ve yavaşladı. Bunu kodla yaparsak bu kadar kasmaz diye düşünüyorum. Bu konuda yardımcı olabilirseniz sevinirim.

 

[Ziynettin]

Merhaba,

Dosyanız ekte.

 

[zehfeysal]

Teşekkür ederim Ziynettin. Emeğinize sağlık.

 

[zehfeysal]

Gönderilen çalışma çok güzel olmuş elinize sağlık. hatta fazlası bile var. Ancak bir yorum daha eklemek istiyorum mümkünse.veri sayfasındaki toplam hanesine yazılan harfler liste sayfasına ilgili tarih ve sicilin olduğu yere aktarılabilir mi?

Ayrıca bir önceki talebimde toplam bilgileri de çalışmışınız eksik olmayın. Mümkünse o toplam bilgiler için uğraşmayın. Oraları istatistiki bilgi olarak kullanmak istiyorum. Sadece veri sayfasındaki bilgilerin ilgili sicil ve tarih kısmına aktarılması yeterli olacaktır.

Şimdiden teşekkür ediyorum

 

[Ziynettin]

Buyrun...

Sub tablo()
Dim S1 As Worksheet, S2 As Worksheet, Krt As Variant
Dim a(), b(), c(), v(), m(), k(), d1 As Object
Dim i As Long, Say As Long, n As Long, x As Byte, z As Double
Dim Toplam As Byte, Cumartesi As Byte, Pazar As Byte
Dim Toplam_saat As Double, Cumartesi_saat As Double, Pazar_saat As Double
Dim Hat As Variant, Tahsis As Variant, Hat_Say As Byte, Tahsis_say As Byte
z = TimeValue(Now)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set S1 = Sheets("veri")
Set S2 = Sheets("liste")
Set d1 = CreateObject("Scripting.Dictionary")
a = S1.Range("B3:G" & S1.Cells(Rows.Count, 2).End(3).Row).Value
    For i = 1 To UBound(a)
    If a(i, 1) <> "" And a(i, 3) <> "" Then
        Krt = CStr(a(i, 1)) & "|" & a(i, 3)
        d1(Krt) = a(i, 6)
    End If
    Next i
b = S2.Range("B3:B" & S2.Cells(Rows.Count, 2).End(3).Row)
c = S2.Range("O3").Resize(, 181).Value
ReDim v(1 To UBound(b), 1 To UBound(c, 2))
For i = 2 To UBound(b)
    Say = Say + 1
    For x = 1 To UBound(c, 2)
        v(Say, x) = d1(CStr(b(i, 1)) & "|" & c(1, x))
    Next x
Next i
S2.Range("O4").Resize(Say, UBound(c, 2)).ClearContents
S2.Range("O4").Resize(Say, UBound(c, 2)) = v
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & CDate(TimeValue(Now) - z), vbInformation
End Sub

 

[zehfeysal]

Yardımlarınız için çok müteşekkir olduğumu bilmenizi isterim öncelikle Ziynettin Bey. Çalışmanın makro kısmında problem yok. Problem benim yapmaya çalıştığım kısımda.

Topla çarpım formülüyle sadece rakam olarak sayıları bulmaya çalışıyorum. harfleri de sayıyor. sadece sayıları nasıl saydırabilirim.yeşil renkli hücrelerde problem var

 

[Ziynettin]

F4 hüceresine;

=TOPLA.ÇARPIM(($O$2:$GM$2="CMT")*EMETİNDEĞİLSE(O4:GM4)*(O4:GM4>1))

 

[zehfeysal]

Harikasınız, Herşey için teşekkür ederim Ziynettin Bey.

 

[Ziynettin]

Rica ederim.
İyi çalışmalar.