• DİKKAT

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

Makro yavaş çalışıyor

kolay gelsin kişinin son değerini alıyor. oysa kaç tane kayıt varsa onların toplamını yazması gerekir.
 
yusufcam' Alıntı:
kolay gelsin kişinin son değerini alıyor. oysa kaç tane kayıt varsa onların toplamını yazması gerekir.
Genişletmek için tıkla ...

PHP: 
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
 
Ziynettin' Alıntı:
PHP: 
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
Genişletmek için tıkla ...
İyi çalışmalar Teşekkür ederim oldu elinize sağlık. Yalnız bir şey soracaktım
For i = 1 To UBound(a)
d(a(i, 5)) = d(a(i, 5)) + a(i, 1) bunu net pancara uygularsam yani polatlıtes e R sütununa nasıl yazacağım.
 
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
 

Ekli dosyalar

Ziynettin' Alıntı:
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
Genişletmek için tıkla ...
Merhaba Teşekkür ederim problemim çözüldü beyninize ellerinize sağlık.
 
yusufcam' Alıntı:
Merhaba 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")
Genişletmek için tıkla ...

kodu bu şekilde yapınız
Rich (BB code): 
 Set S2 = Workbooks(ThisWorkbook.Name).Sheets("TESELLÜM")
 
Sadeleştirilmişi.:cool:
Kod: 
Set S2 = ThisWorkbook.Sheets("TESELLÜM")
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst