• DİKKAT

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

Makro yavaş çalışıyor

Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
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
 

Ekli dosyalar

Son düzenleme:
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.
.
 
Ö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.
.
Genişletmek için tıkla ...
İyi çalışmalar yardımcı olabilirmisiniz
 
VBA kısmı şifre korumalı olan dosyada,
VBA'da kontrol edilmesi gereken kodlarla ilgili destek almayı beklemeniz biraz garip değil mi?
 
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
Genişletmek için tıkla ...
Ö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?
Genişletmek için tıkla ...
Merhaba kolay gelsin şifreyi unutmuşum özür değiştirdim.
 
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
 
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
 
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
Genişletmek için tıkla ...
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ı.
 
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.
 
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.
Genişletmek için tıkla ...
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' 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ı
Genişletmek için tıkla ...
iyi çalışmalar anlatamadığım bir durum yok değil mi dönüş yapmadınız da.
 
Merhaba,

Dosyalarınızın daha ufak bir örneğini istediğiniz sonucu gösterecek şekilde ekler misiniz.
 
İ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.
Genişletmek için tıkla ...

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
 

Ekli dosyalar

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
Ö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
Genişletmek için tıkla ...
Ö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
Genişletmek için tıkla ...
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:P" & son).Value ve S2.[M7].Resize(UBound(a)) = b yaptım modül4 de yardımcı olursanız sevinirim. saygılar.
 
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
 

Ekli dosyalar

Son düzenleme:
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:p" & son).Value ve S2.[M7].Resize(UBound(a)) = b yaptım modül4 de yardımcı olursanız sevinirim. saygılar.
Genişletmek için tıkla ...
Tekrar Merhaba Ancak burada toplayarak almıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst