DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
kolay gelsin kişinin son değerini alıyor. oysa kaç tane kayıt varsa onların toplamını yazması gerekir.
Sub test()
Z = TimeValue(Now)
yol = ThisWorkbook.Path
dosya = "POLATLITES.xlsx"
Application.ScreenUpdating = False
GetObject (yol & "\" & dosya)
Set S1 = Workbooks(dosya).Sheets("Sayfa1")
Set d = CreateObject("scripting.dictionary")
son = S1.Cells(Rows.Count, "P").End(3).Row
a = S1.Range("L2:P" & son).Value
For i = 1 To UBound(a)
d(a(i, 5)) = d(a(i, 5)) + a(i, 1)
Next i
Set S2 = Workbooks("2018 TESELLÜM").Sheets("TESELLÜM")
son = 0
son = S2.Cells(Rows.Count, "E").End(3).Row
a = S2.Range("E7:F" & son).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
say = say + 1
krt = a(i, 1) & "-" & a(i, 2)
If d.exists(krt) Then
b(say, 1) = d(krt)
Else
b(say, 1) = 0
End If
Next i
Application.ScreenUpdating = False
S2.[L7].Resize(UBound(a)) = b
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _
"İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation, "excel.web.tr"
End Sub
İyi çalışmalar Teşekkür ederim oldu elinize sağlık. Yalnız bir şey soracaktımPHP:Sub test() Z = TimeValue(Now) yol = ThisWorkbook.Path dosya = "POLATLITES.xlsx" Application.ScreenUpdating = False GetObject (yol & "\" & dosya) Set S1 = Workbooks(dosya).Sheets("Sayfa1") Set d = CreateObject("scripting.dictionary") son = S1.Cells(Rows.Count, "P").End(3).Row a = S1.Range("L2:P" & son).Value For i = 1 To UBound(a) d(a(i, 5)) = d(a(i, 5)) + a(i, 1) Next i Set S2 = Workbooks("2018 TESELLÜM").Sheets("TESELLÜM") son = 0 son = S2.Cells(Rows.Count, "E").End(3).Row a = S2.Range("E7:F" & son).Value ReDim b(1 To UBound(a), 1 To 1) For i = 1 To UBound(a) say = say + 1 krt = a(i, 1) & "-" & a(i, 2) If d.exists(krt) Then b(say, 1) = d(krt) Else b(say, 1) = 0 End If Next i Application.ScreenUpdating = False S2.[L7].Resize(UBound(a)) = b Workbooks(dosya).Close Application.ScreenUpdating = True MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _ "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation, "excel.web.tr" End Sub
Private Sub CommandButton2_Click()
Z = TimeValue(Now)
yol = ThisWorkbook.Path
dosya = "POLATLITES.xlsx"
Application.ScreenUpdating = False
GetObject (yol & "\" & dosya)
Set S1 = Workbooks(dosya).Sheets("Sayfa1")
Set d = CreateObject("scripting.dictionary")
son = S1.Cells(Rows.Count, "P").End(3).Row
a = S1.Range("L2:R" & son).Value
ReDim b(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
krt = a(i, 5)
If Not d.exists(krt) Then
say = say + 1
d(krt) = say
End If
sat = d(krt)
b(sat, 1) = b(sat, 1) + a(i, 1)
b(sat, 2) = b(sat, 2) + a(i, 7)
b(sat, 3) = b(sat, 3) + 1
Next i
Set S2 = Workbooks("2018 TESELLÜM").Sheets("TESELLÜM")
say = 0: son = 0
son = S2.Cells(Rows.Count, "E").End(3).Row
a = S2.Range("E7:F" & son).Value
ReDim c1(1 To UBound(a), 1 To 2)
ReDim c2(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
say = say + 1
krt = a(i, 1) & "-" & a(i, 2)
If d.exists(krt) Then
c1(say, 1) = b(d(krt), 1)
c1(say, 2) = b(d(krt), 2)
c2(say, 1) = b(d(krt), 3)
Else
c1(say, 1) = 0
c1(say, 2) = 0
c2(say, 1) = 0
End If
Next i
Application.ScreenUpdating = False
S2.[L7].Resize(UBound(a), 2) = c1
S2.[L7].Resize(UBound(a), 2).NumberFormat = "#,##0.00"
S2.[P7].Resize(UBound(a)) = c2
S2.[P7].Resize(UBound(a)).NumberFormat = "#,##0"
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "Fireli / Net / Araç sayısı verileri yazdırıldı." & vbLf & vbLf & _
"İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation, "excel.web.tr"
End Sub
Merhaba Teşekkür ederim problemim çözüldü beyninize ellerinize sağlık.Fireli, net, araç sayısı tek kod ile L, M, P sütunlarına verileriniz yazdırılıyor.
Ekli sayfada aktar butonunu çalıştırıp sonuçları kontrol ediniz.
Kod:Private Sub CommandButton2_Click() Z = TimeValue(Now) yol = ThisWorkbook.Path dosya = "POLATLITES.xlsx" Application.ScreenUpdating = False GetObject (yol & "\" & dosya) Set S1 = Workbooks(dosya).Sheets("Sayfa1") Set d = CreateObject("scripting.dictionary") son = S1.Cells(Rows.Count, "P").End(3).Row a = S1.Range("L2:R" & son).Value ReDim b(1 To UBound(a), 1 To 3) For i = 1 To UBound(a) krt = a(i, 5) If Not d.exists(krt) Then say = say + 1 d(krt) = say End If sat = d(krt) b(sat, 1) = b(sat, 1) + a(i, 1) b(sat, 2) = b(sat, 2) + a(i, 7) b(sat, 3) = b(sat, 3) + 1 Next i Set S2 = Workbooks("2018 TESELLÜM").Sheets("TESELLÜM") say = 0: son = 0 son = S2.Cells(Rows.Count, "E").End(3).Row a = S2.Range("E7:F" & son).Value ReDim c1(1 To UBound(a), 1 To 2) ReDim c2(1 To UBound(a), 1 To 1) For i = 1 To UBound(a) say = say + 1 krt = a(i, 1) & "-" & a(i, 2) If d.exists(krt) Then c1(say, 1) = b(d(krt), 1) c1(say, 2) = b(d(krt), 2) c2(say, 1) = b(d(krt), 3) Else c1(say, 1) = 0 c1(say, 2) = 0 c2(say, 1) = 0 End If Next i Application.ScreenUpdating = False S2.[L7].Resize(UBound(a), 2) = c1 S2.[L7].Resize(UBound(a), 2).NumberFormat = "#,##0.00" S2.[P7].Resize(UBound(a)) = c2 S2.[P7].Resize(UBound(a)).NumberFormat = "#,##0" Workbooks(dosya).Close Application.ScreenUpdating = True MsgBox "Fireli / Net / Araç sayısı verileri yazdırıldı." & vbLf & vbLf & _ "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation, "excel.web.tr" End Sub
Merhaba iyi çalışmalar:Merhaba Teşekkür ederim problemim çözüldü beyninize ellerinize sağlık.
kodu bu şekilde yapınızMerhaba iyi çalışmalar:
çalışıyordu evde. iş yerinde çalıştırdım böyle bir hata alıyorum. Set S2 = Workbooks("2018 TESELLÜM").Sheets("TESELLÜM")
Set S2 = Workbooks(ThisWorkbook.Name).Sheets("TESELLÜM")
Sadeleştirilmişi.
Kod:Set S2 = ThisWorkbook.Sheets("TESELLÜM")
MERHABA TEŞEKKÜR EDERİMkodu bu şekilde yapınız
Rich (BB code):Set S2 = Workbooks(ThisWorkbook.Name).Sheets("TESELLÜM")