Sayfaları sıralama

[mahmutozdemir]

Selamlar,
Sıraya koy butonuna basınca ilk 7 sayfa sabit kalıp diğer sayları b6 dan sonraki listeye göre sıralamak istiyorum. Teşekkürler.

 

[mahmutozdemir]

Örnek dosyayı düzelterek tekrar veriyorum. Sayfaları alfabetik değil belli bir listeye göre sıralayabilirmiyim
Sıraya koy butonuna basınca ilk 7 sayfa sabit kalıp diğer sayları b6 dan sonraki listeye göre sıralamak istiyorum. Teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub Sayfalari_Sirala()
 
    Dim i As Integer, _
        j As Integer
        
    If Worksheets.Count < 8 Then Exit Sub
    
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
    End With
    
    For i = 8 To Worksheets.Count - 1
        For j = 9 To Worksheets.Count
            If StrComp(Sheets(j).Name, Sheets(i).Name, vbTextCompare) = -1 Then
                Worksheets(j).Move before:=Worksheets(i)
            End If
        Next j
    Next i
    
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = False
    End With
    
End Sub

 

[mahmutozdemir]

İlginiz için teşekkürler ,Ama ben Anasayfadaki listeye göre sıralamasını istiyorum bu neye göre sıraladı anlamdım.

 

[Necdet]

İlginiz için teşekkürler ,Ama ben Anasayfadaki listeye göre sıralamasını istiyorum bu neye göre sıraladı anlamdım.

İlk 7 sayfa hariç diğer sayfaları alfabetik sırada sıralıyor, öyle anladım çünkü

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SAYFALARI_SIRALA()
    Dim S1 As Worksheet, X As Integer, Say As Integer, Sayfa As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ANASAYFA")
    Say = 8
    
    For X = 6 To S1.Cells(Rows.Count, 1).End(3).Row
        On Error Resume Next
        Set Sayfa = Sheets(S1.Cells(X, 2).Text)
        On Error GoTo 0
        If Not Sayfa Is Nothing Then
            Sayfa.Move Before:=Sheets(Say)
            Say = Say + 1
        End If
        Set Sayfa = Nothing
    Next
    
    S1.Select
    Set S1 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mahmutozdemir]

Korhan Bey çok teşekkür ederim.