hsayar
03-03-2008, 11:16
Ferhat hocamın yazdığı seçili olmayan sayfaları diziya alma kodunu diğer sayfaları sil makrosuna çevirdim. ancak Diziye lama işlemi yparken grafik sayfasını dikate almamaktadır.
Hata grafik sayfasına geldii zaman next satırında meydana gelmektedir.
For Each sh In ActiveWorkbook.Sheets satırında For Each sh In ActiveWorkbook.Worksheets şeklinde değişiklik yapıldığında grafik sayfaları diziye dahil edilmiyor. Sh seğişkenini Shett olarak tanımlayınca name hatası veriyor
DEĞİŞKENLER MODULÜNDE
Public sh As Worksheet
Sub DigerSayfalarıSil()
'On Error Resume Next
'.Tag = "HsrXLA03"
'Düzen> Diğer Sayfaları Sil
If ActiveWorkbook.ProtectStructure = True Then
MsgBox " Çalışma kitabı korumalıdır, silme işlemi için " & vbCr & _
" çalışma kitabı korumasını kaldırmanız gerekir!", vbCritical, "Korumalı Kitap"
Exit Sub
End If
Dim sayfa, sayfa2 As String, sayfalar, sayfalar2 As String
Dim i%, Y%, X%
Seciliolmayanlar:
Y = 0
For Each sh In ActiveWindow.SelectedSheets
ReDim Preserve arrSh(Y)
arrSh(Y) = sh.Name: Y = Y + 1
Next
Y = 0
If (UBound(arrSh) + 1) = ActiveWorkbook.Sheets.Count Then GoTo Son 'Exit Sub
'MsgBox "Tüm Sayfaları seçtiniz zaten, olmayan sayfayı nasıl sileceksiniz?", vbQuestion + vbOKOnly: Exit Sub
'For Each sh In ActiveWorkbook.Sheets 'ThisWorkbook.Sheets
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook.Sheets
For i = 0 To UBound(arrSh)
If sh.Name = arrSh(i) Then: X = X + 1
Next i
If X = 0 Then
ReDim Preserve arrShX(Y)
arrShX(Y) = sh.Name
Y = Y + 1
End If
X = 0
Next
Dim Prompt As kt_MsgBoxPromptType, rc As Variant: Call ktMsgBoxPromptTypeInit(Prompt)
'------------- SİLMEK İÇİN -----------------
sayfa = "": sayfalar = ""
For i = UBound(arrShX) To 0 Step -1
sayfa = arrShX(i)
sayfalar = " " & sayfa & vbCrLf & sayfalar
Next i
For i = 0 To UBound(arrShX)
Application.DisplayAlerts = False 'ekrana mesaj vermeyi kapat
With Prompt
.Message(1) = Sheets(arrShX(0)).Name & " Evete basarsanız silinecektir."
.FName(1) = "ROMAN": .FSize(1) = 16: .FBold(1) = True: .FColor(1) = vbBlack
.Message(2) = sayfalar & " Tümüne Evete basarsanız Silinecektir!"
.FName(2) = "ROMAN": .FSize(2) = 16: .FBold(2) = True: .FColor(2) = vbBlue
.Message(3) = "Onaylıyor musunuz?"
.FName(3) = "CENT": .FSize(3) = 12: .FBold(3) = True: .FColor(3) = vbRed
End With
cevap = ktMsgBoxEX(Prompt, vbCritical, "O N A Y", _
UserDefBtn:="Tümüne Evet;T,Evet;E,Hayır;H,İptal;P")
If cevap = 9 Then
Sheets(arrShX()).Delete
Exit For: Exit Sub
ElseIf cevap = 10 Then
If ActiveWorkbook.Sheets.Count = (UBound(arrSh) + 1) Then
GoTo Son
Else
Sheets(arrShX(i)).Delete
Sheets(arrSh).Select
GoTo Seciliolmayanlar
End If
ElseIf cevap = 11 Then
ReDim Preserve arrSh(UBound(arrSh) + 1)
arrSh(UBound(arrSh)) = Sheets(arrShX(i)).Name
Sheets(arrSh).Select
GoTo Seciliolmayanlar
ElseIf cevap = 12 Then
Exit For: Exit Sub
End If
Next i
Atla:
GoTo Son
Son:
Application.DisplayAlerts = True
Erase arrSh: Erase arrShX
Set sh = Nothing
End Sub
Hata grafik sayfasına geldii zaman next satırında meydana gelmektedir.
For Each sh In ActiveWorkbook.Sheets satırında For Each sh In ActiveWorkbook.Worksheets şeklinde değişiklik yapıldığında grafik sayfaları diziye dahil edilmiyor. Sh seğişkenini Shett olarak tanımlayınca name hatası veriyor
DEĞİŞKENLER MODULÜNDE
Public sh As Worksheet
Sub DigerSayfalarıSil()
'On Error Resume Next
'.Tag = "HsrXLA03"
'Düzen> Diğer Sayfaları Sil
If ActiveWorkbook.ProtectStructure = True Then
MsgBox " Çalışma kitabı korumalıdır, silme işlemi için " & vbCr & _
" çalışma kitabı korumasını kaldırmanız gerekir!", vbCritical, "Korumalı Kitap"
Exit Sub
End If
Dim sayfa, sayfa2 As String, sayfalar, sayfalar2 As String
Dim i%, Y%, X%
Seciliolmayanlar:
Y = 0
For Each sh In ActiveWindow.SelectedSheets
ReDim Preserve arrSh(Y)
arrSh(Y) = sh.Name: Y = Y + 1
Next
Y = 0
If (UBound(arrSh) + 1) = ActiveWorkbook.Sheets.Count Then GoTo Son 'Exit Sub
'MsgBox "Tüm Sayfaları seçtiniz zaten, olmayan sayfayı nasıl sileceksiniz?", vbQuestion + vbOKOnly: Exit Sub
'For Each sh In ActiveWorkbook.Sheets 'ThisWorkbook.Sheets
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook.Sheets
For i = 0 To UBound(arrSh)
If sh.Name = arrSh(i) Then: X = X + 1
Next i
If X = 0 Then
ReDim Preserve arrShX(Y)
arrShX(Y) = sh.Name
Y = Y + 1
End If
X = 0
Next
Dim Prompt As kt_MsgBoxPromptType, rc As Variant: Call ktMsgBoxPromptTypeInit(Prompt)
'------------- SİLMEK İÇİN -----------------
sayfa = "": sayfalar = ""
For i = UBound(arrShX) To 0 Step -1
sayfa = arrShX(i)
sayfalar = " " & sayfa & vbCrLf & sayfalar
Next i
For i = 0 To UBound(arrShX)
Application.DisplayAlerts = False 'ekrana mesaj vermeyi kapat
With Prompt
.Message(1) = Sheets(arrShX(0)).Name & " Evete basarsanız silinecektir."
.FName(1) = "ROMAN": .FSize(1) = 16: .FBold(1) = True: .FColor(1) = vbBlack
.Message(2) = sayfalar & " Tümüne Evete basarsanız Silinecektir!"
.FName(2) = "ROMAN": .FSize(2) = 16: .FBold(2) = True: .FColor(2) = vbBlue
.Message(3) = "Onaylıyor musunuz?"
.FName(3) = "CENT": .FSize(3) = 12: .FBold(3) = True: .FColor(3) = vbRed
End With
cevap = ktMsgBoxEX(Prompt, vbCritical, "O N A Y", _
UserDefBtn:="Tümüne Evet;T,Evet;E,Hayır;H,İptal;P")
If cevap = 9 Then
Sheets(arrShX()).Delete
Exit For: Exit Sub
ElseIf cevap = 10 Then
If ActiveWorkbook.Sheets.Count = (UBound(arrSh) + 1) Then
GoTo Son
Else
Sheets(arrShX(i)).Delete
Sheets(arrSh).Select
GoTo Seciliolmayanlar
End If
ElseIf cevap = 11 Then
ReDim Preserve arrSh(UBound(arrSh) + 1)
arrSh(UBound(arrSh)) = Sheets(arrShX(i)).Name
Sheets(arrSh).Select
GoTo Seciliolmayanlar
ElseIf cevap = 12 Then
Exit For: Exit Sub
End If
Next i
Atla:
GoTo Son
Son:
Application.DisplayAlerts = True
Erase arrSh: Erase arrShX
Set sh = Nothing
End Sub