Kod:
Sub Aktar()
'16.10.2019 11:36
sonc = Sheets("Ana Sayfa").Cells(Rows.Count, 3).End(3).Row
süre = (sonc * 100 / 10613) + 1
If süre < 49 Then süre = süre + 9
c = MsgBox("'Ana Sayfa' Sayfası hariç diğer tüm sayfalar silinecek ve" & Chr(10) _
& "sizin seçeceğiniz sütuna 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
verivar = 0
sonc = Cells(65500, 3).End(xlUp).Row
ts = Cells(1, Columns.Count).End(xlToLeft).Column
uç111:
toplamsütun = InputBox("Tablonuzda A Sütunundan İtibaren İşlem Yapılmasını İstediğiniz Toplam Sütun Sayısını Giriniz" & Chr(10) & Chr(10) & "Örneğin E sütunu 5 numaralı, M sütunu 13 numaralı Sütundur" & Chr(10) & Chr(10) & "Aktarmayı İptal etmek için, İptal (Cancel) düğmesini tıklayınız" & Chr(10), "Toplam Sütun Sayısını Gir", ts)
If toplamsütun = "" Then
MsgBox "Aktarma İptal Edildi"
Exit Sub
End If
toplamsütun = Int(toplamsütun * 1)
If toplamsütun < 1 Then GoTo uç111
uç222:
sütunseç = InputBox("Gruplandırma Yapılacak Sütun numarası Giriniz" & Chr(10) & Chr(10) & "Örneğin F sütunu 6 numaralı, P sütunu 16 numaralı Sütundur" & Chr(10) & Chr(10) & "Aktarmayı İptal etmek için, İptal (Cancel) düğmesini tıklayınız" & Chr(10), "Gruplandırma Yapılacak Sütun Numarası Gir", ts)
If sütunseç = "" Then
MsgBox "Aktarma İptal Edildi"
Exit Sub
End If
sütunseç = Int(sütunseç * 1)
If sütunseç < 1 Then GoTo uç222
Zaman = Timer
ReDim dizi(sonc, toplamsütun)
For i = 2 To sonc
For j = 1 To toplamsütun
dizi(i, j) = Cells(i, j)
Next
Next
Application.ScreenUpdating = False
sonc = Cells(Rows.Count, 3).End(3).Row
For k = 2 To sonc
If Len(Trim(dizi(k, sütunseç))) > 0 Then
verivar = 1
For i = 1 To Worksheets.Count
If Trim(dizi(k, sütunseç)) = Sheets(i).Name Then
GoTo uç1
End If
Next
sayfaadı = Trim(dizi(k, sütunseç))
Sheets(Aktifsayfa).Copy After:=Sheets(Aktifsayfa)
ActiveSheet.Name = sayfaadı
sayfasayısı = sayfasayısı + 1
soncc = Cells(Rows.Count, 3).End(3).Row
Range(Cells(2, 1), Cells(soncc, 255)).ClearContents
For t = 2 To sonc
If Trim(dizi(t, sütunseç)) = Trim(sayfaadı) Then
soncalt = Cells(65500, 3).End(xlUp).Row
For kk = 1 To toplamsütun
Cells(soncalt + 1, kk) = dizi(t, kk)
Next
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],))"
''''''
''''''
''''''' Range("U2").Select
''''''' ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",DAYS360(R2C35,RC[-1],))"
''''''' Range("V2").Select
''''''' ActiveCell.FormulaR1C1 = _
''''''' "=IF(RC[-2]="""","""",IF(0>RC[-1],""SÜRESİ DOLDU"","""")&"" ""&IF(RC[-1]<30,""(UYARI)"","""")&""""&IF(RC[-1]>30,""GEÇERLİ"","""")&"""")"
''''''
''''''
''''''
''''''
''''''
'''''' Next
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
With Range(Cells(soncalt + 2, 1), Cells(65500, toplamsütun)).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Range(Cells(soncalt + 2, 1), Cells(65500, toplamsütun))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With Range(Cells(soncalt + 1, 1), Cells(soncalt + 1, toplamsütun)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Sheets("Ana Sayfa").Select
End If
uç1:
Next
Application.ScreenUpdating = True
If verivar > 0 Then
Bitis = Chr(10) & Chr(10) & "İşlemin tamamlanma süresi: " & Int(Timer - Zaman) + 1 & " Saniye"
MsgBox "Ana Sayfa " & sütunseç & ". Sütuna Göre Gruplandırılmış haliyle " & sayfasayısı & " Adet Sayfaya Dağıtıldı" & Bitis
Else
MsgBox "Seçtiğiniz Sütunda Veri Bulunmamaktadır. Aktarma Yapılmadı"
End If
End Submerhaba,ekte ki KULÖMER hocam ın hazırladığı kod da işlem yapar iken anasayfa hariç tüm sayfaları siliyor.
rica etsem Ana sayfa ve yanında filtre isimli sayfa var,kodda silinmeyecek sayfayı nereye eklemeliyim ,yardımcı olurmusunuız.
