- Katılım
- 1 Ağustos 2019
- Mesajlar
- 839
- Excel Vers. ve Dili
-
Türkçe excel 2016
İngilizce excel 2016
- Altın Üyelik Bitiş Tarihi
- 19-10-2021
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