Makro yavaş çalışıyor

Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
Altın Üyelik Bitiş Tarihi
11-12-2019
kolay gelsin kişinin son değerini alıyor. oysa kaç tane kayıt varsa onların toplamını yazması gerekir.
 
Z

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,126
Excel Vers. ve Dili
office2010
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
 
Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
Altın Üyelik Bitiş Tarihi
11-12-2019
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.
 
Z

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,126
Excel Vers. ve Dili
office2010
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

Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
Altın Üyelik Bitiş Tarihi
11-12-2019
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.
 
Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
Altın Üyelik Bitiş Tarihi
11-12-2019
yusufcam' Alıntı:
Merhaba Teşekkür ederim problemim çözüldü beyninize ellerinize sağlık.
Genişletmek için tıkla ...
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")
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,872
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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")
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,239
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Sadeleştirilmişi.:cool:
Kod: 
Set S2 = ThisWorkbook.Sheets("TESELLÜM")
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst