Makro yavaş çalışıyor

yusufcam · 29 Kasım 2018

kullandığım bir makro var ancak yavaş çalışıyor. Dosyalar ekte

Sub conn()
Dim S1 As Worksheet
Dim Kaynak As String
Kaynak = Application.ActiveWorkbook.Path & "/" & "POLATLITES" & ".xlsx"
'Application.ScreenUpdating = False
Set wbk = Workbooks.Open(Kaynak, True, True)
Dim S2 As Worksheet
Set S2 = wbk.Sheets("sayfa1")
SONS2 = S2.[A65536].End(3).Row
Set S1 = ThisWorkbook.Sheets("TESELLÜM")
SONS1 = S1.[A65536].End(3).Row
For SXC = 7 To SONS1
S1.Cells(SXC, 12) = 0
Next SXC

For X = 7 To SONS1 '1432
For T = 2 To SONS2
arah = S2.Cells(T, 16) 'Val(TextBox10.Value)
KTON = S2.Cells(T, 12)
If S1.Cells(X, 5) & "-" & S1.Cells(X, 6) = arah Then
S1.Cells(X, 12) = KTON + S1.Cells(X, 12)
End If

Next
Next
wbk.Close False
Set wbk = Nothing
Set S1 = Nothing: Set sh = Nothing
'Application.ScreenUpdating = True
MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM...", vbInformation, "İŞLEM TAMAM"
End Sub

Ömer BARAN · 29 Kasım 2018

Merhaba.

Kod'un çalıştırıldığı ve bilgi çekilen excel belgelerinin, özel bilgi içermeyen birer kopyasını foruma eklerseniz
daha hızlı sonuca ulaşırsınız.

Örnek belge özellikleri ve örnek belge yükleme yöntemine ilişkin kısa açıklama cevabımın atındaki İMZA bölümünde var.
.

yusufcam · 30 Kasım 2018

Ömer BARAN' Alıntı:
Merhaba.

Kod'un çalıştırıldığı ve bilgi çekilen excel belgelerinin, özel bilgi içermeyen birer kopyasını foruma eklerseniz
daha hızlı sonuca ulaşırsınız.

Örnek belge özellikleri ve örnek belge yükleme yöntemine ilişkin kısa açıklama cevabımın atındaki İMZA bölümünde var.
.

İyi çalışmalar yardımcı olabilirmisiniz

Ömer BARAN · 30 Kasım 2018

VBA kısmı şifre korumalı olan dosyada,
VBA'da kontrol edilmesi gereken kodlarla ilgili destek almayı beklemeniz biraz garip değil mi?

yusufcam · 30 Kasım 2018

yusufcam' Alıntı:
kullandığım bir makro var ancak yavaş çalışıyor. Dosyalar ekte

Sub conn()
Dim S1 As Worksheet
Dim Kaynak As String
Kaynak = Application.ActiveWorkbook.Path & "/" & "POLATLITES" & ".xlsx"
'Application.ScreenUpdating = False
Set wbk = Workbooks.Open(Kaynak, True, True)
Dim S2 As Worksheet
Set S2 = wbk.Sheets("sayfa1")
SONS2 = S2.[A65536].End(3).Row
Set S1 = ThisWorkbook.Sheets("TESELLÜM")
SONS1 = S1.[A65536].End(3).Row
For SXC = 7 To SONS1
S1.Cells(SXC, 12) = 0
Next SXC

For X = 7 To SONS1 '1432
For T = 2 To SONS2
arah = S2.Cells(T, 16) 'Val(TextBox10.Value)
KTON = S2.Cells(T, 12)
If S1.Cells(X, 5) & "-" & S1.Cells(X, 6) = arah Then
S1.Cells(X, 12) = KTON + S1.Cells(X, 12)
End If

Next
Next
wbk.Close False
Set wbk = Nothing
Set S1 = Nothing: Set sh = Nothing
'Application.ScreenUpdating = True
MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM...", vbInformation, "İŞLEM TAMAM"
End Sub

Ömer BARAN' Alıntı:
VBA kısmı şifre korumalı olan dosyada,
VBA'da kontrol edilmesi gereken kodlarla ilgili destek almayı beklemeniz biraz garip değil mi?

Merhaba kolay gelsin şifreyi unutmuşum özür değiştirdim.

halit3 · 30 Kasım 2018

dosyanızdaki veriler çok büyük

aşağıdaki kodun kırmızı olan bölümünü kaldırın mavi olan bölümü ekleyiniz.

Rich (BB code):

Sub conn()
Dim S1 As Worksheet
Dim Kaynak As String
Kaynak = Application.ActiveWorkbook.Path & "/" & "POLATLITES" & ".xls"
'Application.ScreenUpdating = False

S1.Range("L7:L1811").ClearContents
Set wbk = Workbooks.Open(Kaynak, True, True)
Dim S2 As Worksheet
Set S2 = wbk.Sheets("sayfa1")
SONS2 = S2.[A65536].End(3).Row

Set S1 = ThisWorkbook.Sheets("TESELLÜM")

SONS1 = S1.[A65536].End(3).Row

'For SXC = 7 To SONS1
'S1.Cells(SXC, 12) = 0
'Next SXC



For X = 7 To SONS1 '1432
For T = 2 To SONS2
arah = S2.Cells(T, 16) 'Val(TextBox10.Value)
KTON = S2.Cells(T, 12)
If S1.Cells(X, 5) & "-" & S1.Cells(X, 6) = arah Then
          S1.Cells(X, 12) = KTON + S1.Cells(X, 12)
        End If
   
Next
Next
wbk.Close False
Set wbk = Nothing
Set S1 = Nothing: Set sh = Nothing
'Application.ScreenUpdating = True
MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM...", vbInformation, "İŞLEM TAMAM"

End Sub

sayfadaki bu kodu da kaldırın

Kod:

Private Sub aWorksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [R1]) Is Nothing Then Exit Sub

For J = 1 To 99
Target.Offset(0, J).Value = Target.Offset(0, J - 1).Value + 1
Next
End Sub

Ziynettin · 30 Kasım 2018

Alternatif çalışma.

Kod:

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)) = 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
    
    Windows(dosya).Visible = False
    Workbooks(dosya).Save
    Workbooks(dosya).Close
    Application.ScreenUpdating = True
    MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _
         "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

yusufcam · 3 Aralık 2018

halit3' Alıntı:

dosyanızdaki veriler çok büyük

aşağıdaki kodun kırmızı olan bölümünü kaldırın mavi olan bölümü ekleyiniz.

Rich (BB code):

Sub conn()
Dim S1 As Worksheet
Dim Kaynak As String
Kaynak = Application.ActiveWorkbook.Path & "/" & "POLATLITES" & ".xls"
'Application.ScreenUpdating = False

S1.Range("L7:L1811").ClearContents
Set wbk = Workbooks.Open(Kaynak, True, True)
Dim S2 As Worksheet
Set S2 = wbk.Sheets("sayfa1")
SONS2 = S2.[A65536].End(3).Row

Set S1 = ThisWorkbook.Sheets("TESELLÜM")

SONS1 = S1.[A65536].End(3).Row

'For SXC = 7 To SONS1
'S1.Cells(SXC, 12) = 0
'Next SXC



For X = 7 To SONS1 '1432
For T = 2 To SONS2
arah = S2.Cells(T, 16) 'Val(TextBox10.Value)
KTON = S2.Cells(T, 12)
If S1.Cells(X, 5) & "-" & S1.Cells(X, 6) = arah Then
          S1.Cells(X, 12) = KTON + S1.Cells(X, 12)
        End If
 
Next
Next
wbk.Close False
Set wbk = Nothing
Set S1 = Nothing: Set sh = Nothing
'Application.ScreenUpdating = True
MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM...", vbInformation, "İŞLEM TAMAM"

End Sub

sayfadaki bu kodu da kaldırın

Kod:

Private Sub aWorksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [R1]) Is Nothing Then Exit Sub

For J = 1 To 99
Target.Offset(0, J).Value = Target.Offset(0, J - 1).Value + 1
Next
End Sub

günaydın kolay gelsin şehir dışındaydım bakma imkanım olmadı kusura bakmayın.
Şimdi baktım kırmızı kodu sildim mavi kodu sizin yazdığınız yere yazdım makro çalışmadı.

Erdem Akdemir · 3 Aralık 2018

Dosyanızın çalışma mantığını biraz anlatırsanız yeni bir kod yazılabilir.
Daha hızlı çalışması için ADO' yu kullanmanızı öneririm. Birkaç saniyede işlem tamamlanacaktır.

yusufcam · 3 Aralık 2018

Erdem_34' Alıntı:
Dosyanızın çalışma mantığını biraz anlatırsanız yeni bir kod yazılabilir.
Daha hızlı çalışması için ADO' yu kullanmanızı öneririm. Birkaç saniyede işlem tamamlanacaktır.

Ekte verilen İki Excel sayfası var. 2018 Tesellüm Verileri alındığı diğeri POLATLITES sayfası burada veriler bulunmakta.
Örneğin POLATLITES sayfasında ''P'' sütununda grup no 85601-10 bu kişi 10 defa ürün getirmiş ''L'' sütunundaki darsız ları toplayarak 2018 Tesellüm sayfasındaki 85601 10 (''E'' ve ''F'') sütunundaki kişinin karşısına ''L'' toplamını alıyor.

Yalnız burda POLATLITES sayfasında grup noda 85601-10 ara karakter var 2018 tesellüm sayfasında 86601 10 ara karakter yok. E ve F sutuları

yusufcam · 4 Aralık 2018

yusufcam' Alıntı:
Ekte verilen İki Excel sayfası var. 2018 Tesellüm Verileri alındığı diğeri POLATLITES sayfası burada veriler bulunmakta.
Örneğin POLATLITES sayfasında ''P'' sütununda grup no 85601-10 bu kişi 10 defa ürün getirmiş ''L'' sütunundaki darsız ları toplayarak 2018 Tesellüm sayfasındaki 85601 10 (''E'' ve ''F'') sütunundaki kişinin karşısına ''L'' toplamını alıyor.

Yalnız burda POLATLITES sayfasında grup noda 85601-10 ara karakter var 2018 tesellüm sayfasında 86601 10 ara karakter yok. E ve F sutuları

iyi çalışmalar anlatamadığım bir durum yok değil mi dönüş yapmadınız da.

Erdem Akdemir · 4 Aralık 2018

Merhaba,

Dosyalarınızın daha ufak bir örneğini istediğiniz sonucu gösterecek şekilde ekler misiniz.

Ziynettin · 4 Aralık 2018

#7. iletideki kodu denediniz mi?

yusufcam · 4 Aralık 2018

İyi Çalışmalar:
Örnek

Erdem_34' Alıntı:
Merhaba,

Dosyalarınızın daha ufak bir örneğini istediğiniz sonucu gösterecek şekilde ekler misiniz.

2018 tesellüm sayfasındaki tesellüm al butonuna basınca POLATLITES sayfasındaki L sutundaki değerleri 2018 tesellüm sayfasındaki 85102 1 kişisinin karşısına toplayarak getiriyor. Ancak veriler çoğalınca işlemi yapması 10 dakika sürüyor. Problem bu şekilde

Ömer BARAN · 4 Aralık 2018

Merhaba.
Sayın @Ziynettin 'in verdiği kodda yer alan ilgili satırı aşağıdaki şekilde değiştirerek dener misiniz?
.

Set S2 = Workbooks(ThisWorkbook.Name).Sheets("TESELLÜM")

yusufcam · 4 Aralık 2018

Merhaba
Denedim çalıştı ancak POLATLITES sayfasını komple boşalttı bu sayfada ki verilerin durması gerekli

Ömer BARAN' Alıntı:
Merhaba.
Sayın @Ziynettin 'in verdiği kodda yer alan ilgili satırı aşağıdaki şekilde değiştirerek dener misiniz?
.

Ömer BARAN · 4 Aralık 2018

Tekrar merhaba.

Kodlar Sayın @Ziynettin'e ait benimkisi sadece bir fikir idi, istenilen sonuç alınamazsa kendisi düzeltme/ilave yapacaktır.

Sonucunda hata da alsanız aşağıdaki ilk kodu (çizginin üstündeki kısım) bir kez çalıştırın (dosyayı kapatmadan önce bu kodu silebilirsiniz).
Ardından da 2018 TESELLÜM belgesinde ikinci kod'u (küçük değişiklikler yapılmış Sayın ziynettin'in verdiği kod) çalıştırın.

Rich (BB code):

Sub goster()
    Windows("POLATLITES.xlsx").Visible = True
End Sub
'___________________________________________________________________________
Sub ziynettin_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)) = a(i, 1)
        Next i
    Set S2 = Workbooks(ThisWorkbook.Name).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
    S2.[L7].Resize(UBound(a)) = b
    Windows(dosya).Close SaveChanges:=True
    Application.ScreenUpdating = True
    MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _
         "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

yusufcam · 4 Aralık 2018

Merhaba
Sayın @@Ziynettin

Ömer BARAN' Alıntı:

Tekrar merhaba.

Kodlar Sayın @Ziynettin'e ait benimkisi sadece bir fikir idi, istenilen sonuç alınamazsa kendisi düzeltme/ilave yapacaktır.

Sonucunda hata da alsanız aşağıdaki ilk kodu (çizginin üstündeki kısım) bir kez çalıştırın (dosyayı kapatmadan önce bu kodu silebilirsiniz).
Ardından da 2018 TESELLÜM belgesinde ikinci kod'u (küçük değişiklikler yapılmış Sayın ziynettin'in verdiği kod) çalıştırın.

Rich (BB code):

Sub goster()
    Windows("POLATLITES.xlsx").Visible = True
End Sub
'___________________________________________________________________________
Sub ziynettin_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)) = a(i, 1)
        Next i
    Set S2 = Workbooks(ThisWorkbook.Name).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
    S2.[L7].Resize(UBound(a)) = b
    Windows(dosya).Close SaveChanges:=True
    Application.ScreenUpdating = True
    MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _
         "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

Ömer BARAN' Alıntı:

Tekrar merhaba.

Kodlar Sayın @Ziynettin'e ait benimkisi sadece bir fikir idi, istenilen sonuç alınamazsa kendisi düzeltme/ilave yapacaktır.

Sonucunda hata da alsanız aşağıdaki ilk kodu (çizginin üstündeki kısım) bir kez çalıştırın (dosyayı kapatmadan önce bu kodu silebilirsiniz).
Ardından da 2018 TESELLÜM belgesinde ikinci kod'u (küçük değişiklikler yapılmış Sayın ziynettin'in verdiği kod) çalıştırın.

Rich (BB code):

Sub goster()
    Windows("POLATLITES.xlsx").Visible = True
End Sub
'___________________________________________________________________________
Sub ziynettin_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)) = a(i, 1)
        Next i
    Set S2 = Workbooks(ThisWorkbook.Name).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
    S2.[L7].Resize(UBound(a)) = b
    Windows(dosya).Close SaveChanges:=True
    Application.ScreenUpdating = True
    MsgBox "FİRELİ PANCAR AKTARILMIŞTIR YUSUF ÇAM..." & vbLf & vbLf & _
         "İşlem süreniz : " & CDate(TimeValue(Now) - Z), vbInformation
End Sub

Merhaba ;
Sayın @Ziynettin'e de size de çok teşekkür ederim.
Küçük bir sorunum daha var Net pancar butonuyla da polatlıtes deki R sütununda ki firesiz değerlerini almak için kodlardaki sütunları değiştirdi ancak beceremedim. a = S1.Range("R2

" & son).Value ve S2.[M7].Resize(UBound(a)) = b yaptım modül4 de yardımcı olursanız sevinirim. saygılar.

halit3 · 4 Aralık 2018

Merhaba yüklediğim dosyada uyumsuzluk gördüm şimdi her iki dosyayı da yüklüyorum 2018 TESELLÜM dosyasındaki Sayfa1 de kodları çalıştırınız ve irdeleyiniz.

PHP:

Private Sub CommandButton1_Click()

Columns("A:B").ClearContents
Cells(1, 2).Value = "darasız"
Cells(1, 1).Value = "grup no"

Klasor = ThisWorkbook.Path
dosya = Klasor & "\POLATLITES.xlsx"
Set Kayit = CreateObject("ADODB.recordset")
yaz1 = "SELECT `Sayfa1$`.darasız, `Sayfa1$`.`grup no`"
'baglan = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007

Kayit.Open yaz1 & " FROM [Sayfa1$] ", baglan, 3, 2
MsgBox Kayit.Fields.Count & Chr(10) & Kayit.RecordCount
Cells(2, 1).CopyFromRecordset Kayit
Kayit.Close
Set Kayit = Nothing
MsgBox "işlem tamam"
End Sub

Private Sub CommandButton2_Click()

Application.ScreenUpdating = False

ZBasla = TimeValue(Now)
zaman = Timer

Set S1 = Sheets("TESELLÜM")
SONS1 = S1.Cells(Rows.Count, "A").End(3).Row

Set S2 = Sheets("sayfa1")
SONS2 = S2.Cells(Rows.Count, "A").End(3).Row


For X = 7 To SONS1 '1432
veri1 = S1.Cells(X, 5) & "-" & S1.Cells(X, 6)
deg1 = 0
For t = 2 To SONS2
If veri1 = S2.Cells(t, 2) Then
deg1 = deg1 + S2.Cells(t, 1)
End If
Next
S1.Cells(X, "L") = deg1

Next

zBitis = TimeValue(Now)
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

yusufcam · 4 Aralık 2018

Tekrar Merhaba;

yusufcam' Alıntı:
Merhaba
Sayın @@Ziynettin

Merhaba ;
Sayın @Ziynettin'e de size de çok teşekkür ederim.
Küçük bir sorunum daha var Net pancar butonuyla da polatlıtes deki R sütununda ki firesiz değerlerini almak için kodlardaki sütunları değiştirdi ancak beceremedim. a = S1.Range("R2" & son).Value ve S2.[M7].Resize(UBound(a)) = b yaptım modül4 de yardımcı olursanız sevinirim. saygılar.

Tekrar Merhaba Ancak burada toplayarak almıyor.

Makro yavaş çalışıyor

yusufcam

Ekli dosyalar

Ömer BARAN

Uzman

yusufcam

Ömer BARAN

Uzman

yusufcam

halit3

Uzman

Ziynettin

Destek Ekibi

yusufcam

Erdem Akdemir

Destek Ekibi

yusufcam

yusufcam

Erdem Akdemir

Destek Ekibi

Ziynettin

Destek Ekibi

yusufcam

Ekli dosyalar

Ömer BARAN

Uzman

yusufcam

Ömer BARAN

Uzman

yusufcam

halit3

Uzman

Ekli dosyalar

yusufcam