makroyu hızlandırmak

metin_0606 · 6 Eylül 2019

Kullanmış olduğum excel listesi 4000 satırlık bir personel listesi. bu listede kullanmış olduğum makro işlemi yaklaşık 5 dakikada gerçekleştiriyor. Bu süreyi kısaltmak mümkünmü acaba

Kod:

Sub Aktar()
'05.09.2019  08:40

   
    sonc = Sheets("Ana Sayfa").Cells(Rows.Count, 3).End(3).Row
    süre = (sonc * 180 / 7500) + 1
   
    c = MsgBox("'Ana Sayfa'  sayfası hariç diğer tüm sayfalar silinecek ve" & Chr(10) _
    & "Y sütununa göre Gruplandırılmış Aktarma İşlemi başlatılacak." & Chr(10) & Chr(10) _
     & "(İşlem Süresi bilgisayarınızın hızına bağlı olarak yaklaşık " & Int(süre) & "  Saniye)" & Chr(10) & Chr(10) & "Onaylıyor musunuz?", vbOKCancel)
    If c = vbCancel Then End
   
    Zaman = Timer
   
   
    Sheets("Ana Sayfa").Select
    Aktifsayfa = "Ana Sayfa"
   
uç2:

    For i = 1 To Worksheets.Count
   
        If Worksheets(i).Name <> Aktifsayfa Then
       
                     Application.DisplayAlerts = False
                     Worksheets(i).Delete
                     Application.DisplayAlerts = True
                    
                     GoTo uç2
                    
        End If
                    
                    
    Next
   
    timer1 = Timer
    Do While Timer - timer1 < 0.7
    Loop
   
    Application.ScreenUpdating = False
   
    sonc = Cells(Rows.Count, 3).End(3).Row
   
    For k = 2 To sonc
       
'        If k < 9 Then MsgBox k
       
        If Len(Trim(Cells(k, 25))) > 0 Then
   
            For i = 1 To Worksheets.Count
               
                    If Trim(Cells(k, 25)) = Sheets(i).Name Then
                   
                        GoTo uç1
                   
                    End If
               
            Next
       
       
            sayfaadı = Trim(Cells(k, 25))
       
            Sheets(Aktifsayfa).Copy After:=Sheets(Aktifsayfa)
           
            ActiveSheet.Name = sayfaadı
           
           
'uç3:
            soncc = Cells(Rows.Count, 3).End(3).Row
   
            For t = 2 To soncc
           
                Cells(2, 5) = t
           
                If Trim(Cells(t, 25)) = Trim(sayfaadı) Then
               
                Else

                        sonttt = Cells(Rows.Count, 3).End(3).Row
                        If sonttt < t Then GoTo uç4
                       
                        Do While Trim(Cells(t, 25)) <> Trim(sayfaadı)
                       
                            Rows(t & ":" & t).Delete
                           
                            sonttt = Cells(Rows.Count, 3).End(3).Row
                            If sonttt < t Then GoTo uç4
'                            say = say + 1
                       
                       
                        Loop
                       
                        sonttt = Cells(Rows.Count, 3).End(3).Row
                        If sonttt < t Then GoTo uç4
                       
'                        If Trim(Cells(t, 25)) <> Trim(sayfaadı) Then Rows(t & ":" & t).Delete
                       
                       
'                        Rows(t & ":" & t).Select
'                        Selection.Delete Shift:=xlUp
'                        t = t - 1
                       
'                        GoTo uç3
               
                End If
               
            Next
           
uç4:
           
            soncc = Cells(Rows.Count, 3).End(3).Row
           
            For h = 2 To soncc
           
                Do While Trim(Cells(h, 23)) <> "Etkin"
               
                    Rows(h & ":" & h).Delete
                   
                    sonttt = Cells(Rows.Count, 3).End(3).Row
                    If sonttt < h Then GoTo uç4
'                            say = say + 1
               
                Loop
               
           
               
                Range("U" & h).Select
                ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",DAYS360(R2C35,RC[-1],))"
           
            Next

            Sheets("Ana Sayfa").Select
       
        End If
uç1:
       
    Next
   
    Application.ScreenUpdating = True
   
    Bitis = Chr(10) & Chr(10) & "İşlemin tamamlanma süresi:  " & Int(Timer - Zaman) + 1 & "  Saniye"
   
    MsgBox "Gruplandırılmış Aktarma İşlemi Tamamlandı" & Bitis


End Sub

Korhan Ayhan · 7 Eylül 2019

Merhaba,

Elbette daha hızlı çalışacak kod tasarlanabilir. Fakat örnek dosya ekleyerek yapmak istediğiniz işlemi açıklamalısınız.

metin_0606 · 7 Eylül 2019

Tabiki Korhan Bey Şimdi Benim 4000 satırlık excel personel listem var tabiki bu gün geçtikçe artacak. Şimdi ben bu personelleri W sütünüdakı çalışma durumu Etkin olanları baz alarak, Y sütunundaki gruplara göre ayırıp sayfalara dağıt dediğim zaman makro bu işlemi yaklaşık 4-5 dakika arası gerçekleştiriyor. Bu süreyi farklı bir makro ile kısaltmamız mümkünmü acaba. Birde gruplara ayırdıktan sonra her sayfanın bir köşesine toplam kaç personel olduğunu yazdırabilirmiyiz.

Korhan Ayhan · 7 Eylül 2019

Kendi kodlarıız yerine aşağıdaki kodu deneyiniz.

Benim bilgisayarımda işlem 4-5 saniye civarında sonuçlanıyor.

Kod:

Option Explicit

Sub Sayfalara_Verileri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet
    Dim Tablo As Range, X As Long, Son As Long, Zaman As Double
    Dim Grup As Variant, Grup_Listesi As Object, Veri As Variant, Onay As Byte
   
    Onay = MsgBox("Verileriniz sayfalara aktarılacaktır." & Chr(10) & _
                  "İşlemi onaylıyor musunuz?", vbExclamation + vbYesNo)
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
   
    Zaman = Timer
   
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "Ana Sayfa", "data"
            Case Else: Sayfa.Delete
        End Select
    Next
   
    Set Grup_Listesi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Ana Sayfa")
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
   
    Set Tablo = S1.Range("A1:Y" & Son)
   
    Veri = S1.Range("Y2:Y" & Son).Value
   
    For X = LBound(Veri) To UBound(Veri)
        Grup_Listesi(Veri(X, 1)) = 1
    Next
   
    S1.Range("XFD1").Value = S1.Range("Y1").Value
   
    For Each Grup In Grup_Listesi.Keys()
        If Grup <> Empty Then
            S1.Range("XFD2").Value = Grup
            If Sayfa_Kontrol(Grup) Then
                Sheets(Grup).Cells.Clear
                Tablo.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=S1.Range("XFD1:XFD2"), _
                CopyToRange:=Sheets(Grup).Range("A1"), _
                Unique:=False
                S1.DrawingObjects.Delete
                S1.Columns.AutoFit
            Else
                Set S2 = Sheets.Add
                S2.Move After:=Worksheets(Worksheets.Count)
                S2.Name = Grup
                Tablo.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=S1.Range("XFD1:XFD2"), _
                CopyToRange:=S2.Range("A1"), _
                Unique:=False
                S2.DrawingObjects.Delete
                S2.Columns.AutoFit
            End If
        End If
    Next
   
    S1.Select
    S1.Columns("XFD:XFD").Delete
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Grup_Listesi = Nothing
    Set Tablo = Nothing
   
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Function Sayfa_Kontrol(Sayfa_Adi As Variant) As Boolean
    On Error Resume Next
    Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa_Adi).Name) > 0)
End Function

Ziynettin · 7 Eylül 2019

@korhan Beyin yazdığı kod üzerinden yapılan çalışmadır. Ekli dosyanıza göre işlem süresi; 1 saniyeden az bende.

Kod:

Sub test()
Zaman = Timer
Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "Ana Sayfa", "data"
            Case Else: Sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = 0
    Set d = CreateObject("scripting.dictionary")
    Set s1 = Sheets("Ana Sayfa")
    a = s1.Range("A2:Y" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    sy = UBound(a, 2)
        For i = 1 To UBound(a)
            If Not a(i, sy) = "" Then d(a(i, sy)) = ""
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For x = 1 To UBound(a)
                If a(x, 23) = "Etkin" Then
                    If a(x, sy) = S2.Name Then
                        say = say + 1
                        For y = 1 To sy
                            b(say, y) = a(x, y)
                        Next y
                    End If
                End If
            Next x
        s1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        S2.[A2].Resize(say, sy) = b
        S2.[A2].Resize(say, sy).Columns.AutoFit
        S2.DrawingObjects.Delete
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        say = 0
    Next i
    s1.Select
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

metin_0606 · 7 Eylül 2019

Değerli hocalarim şuan yolda olduğum için kodu deneyemedim deneyince sonucu buradan paylaşırım destekleriniz için teşekkürler

kulomer46 · 7 Eylül 2019

Sayın Korhan Ayhan ve Sayın Ziynettin arkadaşlarımızın yukardaki kodları mükemmel güzel ve hızlı çalışıyor.

Emeklerine sağlık.

Selamlar...

metin_0606 · 7 Eylül 2019

Ziynettin' Alıntı:

@korhan Beyin yazdığı kod üzerinden yapılan çalışmadır. Ekli dosyanıza göre işlem süresi; 1 saniyeden az bende.

Kod:

Sub test()
Zaman = Timer
Application.DisplayAlerts = False
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "Ana Sayfa", "data"
            Case Else: Sayfa.Delete
        End Select
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = 0
    Set d = CreateObject("scripting.dictionary")
    Set S1 = Sheets("Ana Sayfa")
    a = S1.Range("A2:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Value
    sy = UBound(a, 2)
        For i = 1 To UBound(a)
            If Not a(i, sy) = "" Then d(a(i, sy)) = ""
        Next i
    ReDim b(1 To UBound(a), 1 To sy)
    For i = 0 To d.Count - 1
        Set S2 = Sheets.Add
        S2.Move After:=Worksheets(Worksheets.Count)
        S2.Name = d.keys()(i)
            For X = 1 To UBound(a)
                If a(X, sy) = S2.Name Then
                    say = say + 1
                    For y = 1 To sy
                        b(say, y) = a(X, y)
                    Next y
                End If
            Next X
        S1.[A1:Y1].Copy Sheets(S2.Name).[A1]
        S2.[A2].Resize(say, sy) = b
        S2.[A2].Resize(say, sy).Columns.AutoFit
        S2.DrawingObjects.Delete
        S2.[A2].Resize(say, sy).Borders.LineStyle = 1
        say = 0
    Next i
Application.ScreenUpdating = 1
MsgBox "Veriler sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Üstatlar kodlar mükemmel çalışıyor. Ancak sayfalara grupları dağıtırken işten ayrılan personelide listeliyor. Sadece Etkin personeli listelememiz münkünmü

Ziynettin · 7 Eylül 2019

Kodu tekrar deneyiniz.

metin_0606 · 7 Eylül 2019

Ziynettin' Alıntı:
Kodu tekrar deneyiniz.

Hocam çok teşekkür ederim süper oldu

Ziynettin · 7 Eylül 2019

Rica ederim.
Kolay gelsin.

metin_0606 · 7 Eylül 2019

Ziynettin' Alıntı:
Rica ederim.
Kolay gelsin.

Ziynettin hocam şimdi ben kendi listemde forumulü uyguladığımda hata verdi. ancak benim listemde hücrede boş alan yok. Hepsi dolu. Örnek listede boş hüçreler vardı. Ondanmı hata verdi acaba

Ziynettin · 7 Eylül 2019

Kodun hangi satırında hata veriyor.

metin_0606 · 7 Eylül 2019

Ziynettin' Alıntı:
Kodun hangi satırında hata veriyor.

If Not a(i, sy) = "" Then d(a(i, sy)) = ""

Ziynettin · 7 Eylül 2019

Bu satırdaki hatayı çalıştığınız dosyada görmeden birşey diyemem.

metin_0606 · 8 Eylül 2019

Ziynettin' Alıntı:
Bu satırdaki hatayı çalıştığınız dosyada görmeden birşey diyemem.

ziynettin hocam sorun bazı verilerin hücre dışına taşması ile ilgiliymiş hizalamadan metni kaydır dedim düzeldi. Ancak grupları dağıtırken Ana Sayfa daki tablonun boyutlarını küçülterek dağıtım yapıyor Yavaş çalışan makroda tabloyu orjinal boyutlarına bağlı kalarak verileri dağıtıyordu. Buna bir çözüm bulabilirmiyiz

muhsar · 8 Eylül 2019

hocam öğrenmek amaçlı uğraşıyorum;

If a(x, 23) = "Etkin" Then
kodun bu kısmında 23 sütun no ve "etkin" hücre içeriği bu kısmı kolun no ve başka bir içerikle değiştirebildim fakat gruplamayı Y sütununa göre değilde mesela H sütununa göre yaptırmak için kod da nereleri değiştirmek gerekir,

rica etsem müsait zamanınızda bakabilirmisiniz

Ziynettin · 8 Eylül 2019

muhsar' Alıntı:
hocam öğrenmek amaçlı uğraşıyorum;

If a(x, 23) = "Etkin" Then
kodun bu kısmında 23 sütun no ve "etkin" hücre içeriği bu kısmı kolun no ve başka bir içerikle değiştirebildim fakat gruplamayı Y sütununa göre değilde mesela H sütununa göre yaptırmak için kod da nereleri değiştirmek gerekir,

rica etsem müsait zamanınızda bakabilirmisiniz

Soruyu örnek tablo ile yeni konu açmanız daha iyi olur. Konu karışıklığı önlemek için.

makroyu hızlandırmak

metin_0606

Korhan Ayhan

Administrator

metin_0606

Ekli dosyalar

Korhan Ayhan

Administrator

Ziynettin

Destek Ekibi

metin_0606

kulomer46

metin_0606

Ziynettin

Destek Ekibi

metin_0606

Ziynettin

Destek Ekibi

metin_0606

Ziynettin

Destek Ekibi

metin_0606

Ziynettin

Destek Ekibi

metin_0606

muhsar

Ziynettin

Destek Ekibi