Kontrollü yeni sayfa oluşturma

[ugurex]

Merhaba,
Aşağıdaki kodla "AnaSayfa" sayfasındaki F12 hücresindeki değer ismiyle yeni sayfa oluşturuyor (aynı çalışma kitabı içinde), fakat o isimde sayfa mevcut ise kontrolü sonra yapıyor ve sayfayı kopyaladıktan sonra "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..." uyarısı veriyor.

Öncelikle; eğer F12 deki değer ismi ile (aynı çalışma kitabı içinde) sayfa mevcut ise uyarı versin ve işlem dursun, o isimde sayfa yoksa; sayfayı kopyalayıp isim versin istiyorum, nasıl yapabiliriz?

Sub yenipersonel()
'
' yenipersonel Makro
'
    
    Sheets("Sablon").Visible = True
    Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
    NewPageName = Sheets("AnaSayfa").Range("f12").Value
    If NewPageName = Cancel Then Exit Sub
    For a = 1 To Sheets.Count
    If UCase(Sheets(a).Name) = UCase(NewPageName) Then
    MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
    End If
    Next
    ActiveWindow.ActiveSheet.Name = NewPageName
End Sub

 

[yanginci34]

Birde böyle deneyin
Sub yenipersonel()
'
' yenipersonel Makro
'

Sheets("Sablon").Visible = True


For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
Exit Sub
Else
Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
If NewPageName = Cancel Then Exit Sub
NewPageName = Sheets("AnaSayfa").Range("f12").Value
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
End Sub

 

[ugurex]

Birde böyle deneyin
Sub yenipersonel()
'
' yenipersonel Makro
'

Sheets("Sablon").Visible = True


For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
Exit Sub
Else
Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
If NewPageName = Cancel Then Exit Sub
NewPageName = Sheets("AnaSayfa").Range("f12").Value
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
End Sub

olmadı malesef, sayfa varsa da yoksa da kopyalayıp, isim de vermeden kalıyor

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub yenipersonel()
'
' yenipersonel Makro
'
    
    NewPageName = Sheets("AnaSayfa").Range("f12").Value
    
    For a = 1 To Sheets.Count
        If UCase(Sheets(a).Name) = UCase(NewPageName) Then
            MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
            Exit Sub
        End If
    Next
    
    Sheets("Sablon").Visible = True
    Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
    
    'If NewPageName = Cancel Then Exit Sub

    ActiveWindow.ActiveSheet.Name = NewPageName
    
End Sub

 

[ugurex]

Merhaba,

Bu şekilde deneyin.

Sub yenipersonel()
'
' yenipersonel Makro
'
   
    NewPageName = Sheets("AnaSayfa").Range("f12").Value
   
    For a = 1 To Sheets.Count
        If UCase(Sheets(a).Name) = UCase(NewPageName) Then
            MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
            Exit Sub
        End If
    Next
   
    Sheets("Sablon").Visible = True
    Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
   
    'If NewPageName = Cancel Then Exit Sub

    ActiveWindow.ActiveSheet.Name = NewPageName
   
End Sub

Teşekkür ediyorum, tam istediğim gibi oldu, emeğinize sağlık...

 

[yanginci34]

Denermisiniz.
Sub yenipersonel()
'
' yenipersonel Makro
'
Sayfa = Sheets("AnaSayfa").Range("f12").Value
If SayfaVarMi(Sayfa) Then

MsgBox "Bu Sicil No ile Personel Mevcuttur Lütfen Kontrol Edin..."
Exit Sub

Else
Sheets("Sablon").Copy After:=Worksheets(Worksheets.Count)
NewPageName = Sayfa
'If NewPageName = Cancel Then Exit Sub
End If
ActiveWindow.ActiveSheet.Name = NewPageName
End Sub
Function SayfaVarMi(SayfaAdi As String) As Boolean
On Error Resume Next
SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[yanginci34]

Ömer Bey cevap vermiş görmedim benim gönderdiğim eğer çalışırsa alternatif olsun.

 

[ugurex]

Ömer Bey cevap vermiş görmedim benim gönderdiğim eğer çalışırsa alternatif olsun.

teşekkürler