Excell sayfa adlarının belirli bir hücreden alınması işlevinde hata..!

[TURANNET]

Merhaba,

Sub Sayfa_adi_degistir_hücreden_al()
For i = 3 To Worksheets.Count
Sheets(i).Name = Sheets(i).Range("B2")
Next i
End Sub

kodları ile işlem gerçekleşiyor.
Ancak bazı sayfalarda "B2" hücresinde aynı değer gelebiliyor ve dolayısıyla hata veriyor.
Tekrar eden değerlere gelindiğinde, sayfa adlarının sonuna; ilk tekrarda "_D1", 2.' sinde "_D2", .........., "_D(i)" şeklinde belirteçler eklenebilirmi.Yalnız her yeni tekrarlayan değerlerde "_D" belirtecinin tekrar 1' den başlaması gerekiyor.
Örneğin;
Sayfa 1 ("B2") hücresi=150 =>Sayfa 1 adı =150 olacaktır
Sayfa 2 ("B2") hücresi=150 =>Sayfa 2 adı =150_D1 olsun

Sayfa 3 ("B2") hücresi=180 =>Sayfa 3 adı =180 olacaktır
Sayfa 4 ("B2") hücresi=180 =>Sayfa 4 adı =180_D1
Sayfa 5 ("B2") hücresi=180 =>Sayfa 5 adı =180_D2
olsun
gibi.

Teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sayfa_Adi_Degistir_Hucreden_Al()
    Dim X As Integer, Y As Integer
    Dim WS As Worksheet, Say As Integer
    
    For X = 3 To Worksheets.Count
        Say = 0
        On Error Resume Next
        Set WS = Nothing
        Set WS = Sheets(CStr(Sheets(X).Range("B2")))
        On Error GoTo 0
        If WS Is Nothing Then
            Sheets(X).Name = Sheets(X).Range("B2")
        Else
            If WS.Index > X Then
                WS.Name = Replace(Time, ":", "")
                Sheets(X).Name = Sheets(X).Range("B2")
            Else
                For Y = 3 To X - 1
                    If Left(Sheets(Y).Name, Len(Sheets(X).Range("B2"))) = CStr(Sheets(X).Range("B2")) Then
                        Say = Say + 1
                    End If
                Next
                If Say = 0 Then
                    Sheets(X).Name = Sheets(X).Range("B2")
                Else
                    Sheets(X).Name = Sheets(X).Range("B2") & "_D" & Say
                End If
            End If
        End If
    Next
    
    MsgBox "Sayfa isimleri güncellenmiştir.", vbInformation
End Sub

 

[veyselemre]

Sub test()
    Dim i As Integer, sf$
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Worksheets.Count
            sf = Sheets(i).Range("B2").Value
            If Not .exists(sf) Then
                Sheets(i).Name = sf
                .Item(sf) = 0
            Else
                Sheets(i).Name = sf & "_D" & .Item(sf) + 1
                .Item(sf) = .Item(sf) + 1
            End If
        Next
    End With
    MsgBox "Sayfa isimleri güncellenmiştir.", vbInformation
End Sub

 

[TURANNET]

Çok teşekkür ederim Korhan bey.
Test ettim ve çalışıyor.

 

[TURANNET]

Sub test()
    Dim i As Integer, sf$
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Worksheets.Count
            sf = Sheets(i).Range("B2").Value
            If Not .exists(sf) Then
                Sheets(i).Name = sf
                .Item(sf) = 0
            Else
                Sheets(i).Name = sf & "_D" & .Item(sf) + 1
                .Item(sf) = .Item(sf) + 1
            End If
        Next
    End With
    MsgBox "Sayfa isimleri güncellenmiştir.", vbInformation
End Sub

Sub test()
    Dim i As Integer, sf$
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Worksheets.Count
            sf = Sheets(i).Range("B2").Value
            If Not .exists(sf) Then
                Sheets(i).Name = sf
                .Item(sf) = 0
            Else
                Sheets(i).Name = sf & "_D" & .Item(sf) + 1
                .Item(sf) = .Item(sf) + 1
            End If
        Next
    End With
    MsgBox "Sayfa isimleri güncellenmiştir.", vbInformation
End Sub

Sub test()
    Dim i As Integer, sf$
    With CreateObject("Scripting.Dictionary")
        For i = 3 To Worksheets.Count
            sf = Sheets(i).Range("B2").Value
            If Not .exists(sf) Then
                Sheets(i).Name = sf
                .Item(sf) = 0
            Else
                Sheets(i).Name = sf & "_D" & .Item(sf) + 1
                .Item(sf) = .Item(sf) + 1
            End If
        Next
    End With
    MsgBox "Sayfa isimleri güncellenmiştir.", vbInformation
End Sub

Çok teşekkür ederim Veysel bey.
Test ettim ve çalışıyor.