Sayfa adı sayıdan oluşan sayfaları yan yana sıralama

hopeful · 20 Mart 2018

Merhabalar,

Öyle bir makro olsun ki, sayfa adı sayıdan oluşan ne kadar sayfa varsa; küçükten büyüğe yanyana sıralansın (Sayfaların içindeki verilerde değişiklik olmadan...)

Bu örnekte; 14,3,13,4,35,17,25,12,1,5,2 sayfa adlarından oluşan excel dosyası mevcut. Sayfalar artıp azalabilmektedir.

Makro çalıştırılınca, sayı adlı sayfalar küçükten büyüğe yan yana gelsin…

Yardımınlarınızı rica ederim,

Korhan Ayhan · 20 Mart 2018

Deneyiniz.

Kod:

Sub SAYFALARI_SIRALA()
    Dim S1 As Worksheet, Satır As Long, Sayfa As Variant, Son As Long, Sıra As Integer
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("SIRALAMA_SAYFASI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set S1 = Sheets.Add(Sheets(6))
    S1.Name = "SIRALAMA_SAYFASI"
    S1.Cells(1, 1) = "SAYFA İSİMLERİ"

    Satır = 2

    For Each Sayfa In ThisWorkbook.Worksheets
        If IsNumeric(Sayfa.Name) Then
            S1.Cells(Satır, 1) = Sayfa.Name
            Satır = Satır + 1
        End If
    Next
    
    S1.Range("A2:A" & Rows.Count).Sort S1.Range("A2"), xlAscending
    
    Son = S1.Cells(Rows.Count, 1).End(3).Row
    Sıra = 7
    
    For Each Sayfa In S1.Range("A2:A" & Son)
        Sheets(Sayfa.Text).Move Before:=Sheets(Sıra)
        Sıra = Sıra + 1
    Next

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("SIRALAMA_SAYFASI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Application.ScreenUpdating = True

    MsgBox "Sayısal isimli sayfalar sıralanmıştır.", vbInformation
End Sub

alicimri · 20 Mart 2018

Alternatif olsun.

Kod:

Sub aa()
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
For e = 1 To Sheets.Count
if IsNumeric(Sheets(e).Name) then
arr.Add Sheets(e).Name * 1 
end if
' Burada 1 ile çarpma işlemi yapılmaz ise alınan sayfa isimlerini Metin sıralamasına sokuyor.
 Örnek 1, 11, 4, 44, 5.... gibi
Next
arr.Sort
'Büyükten Küçüğe sıralama için
'arr.Reverse
For i = 0 To Sheets.Count - 1
if IsNumeric(Sheets(i).Name) then
Sheets(CStr(arr(i))).Move Before:=Sheets(i + 1)
End if
Next
End Sub

AHMETMANAV · 21 Mart 2018

numarik sırama için kod

Sub sayfasirala()
Application.ScreenUpdating = False
Sheets.Add
ActiveSheet.Move After:=Sheets(Sheets.Count)
Set s1 = Sheets(Sheets.Count)
For a = 1 To Sheets.Count - 1
s1.Cells(a, "a") = Sheets(a).Name
s1.[a:a].Sort Key1:=s1.[a1]
deg = Sheets(a).Name
If IsNumeric(deg) = True Then deg = Val(Sheets(a).Name)
say = WorksheetFunction.Match(deg, s1.[a:a], 0)
Sheets(a).Move Before:=Sheets(say)
Next
Application.DisplayAlerts = False
s1.Delete
End Sub

hopeful · 21 Mart 2018

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Sub SAYFALARI_SIRALA()
    Dim S1 As Worksheet, Satır As Long, Sayfa As Variant, Son As Long, Sıra As Integer
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("SIRALAMA_SAYFASI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set S1 = Sheets.Add(Sheets(6))
    S1.Name = "SIRALAMA_SAYFASI"
    S1.Cells(1, 1) = "SAYFA İSİMLERİ"

    Satır = 2

    For Each Sayfa In ThisWorkbook.Worksheets
        If IsNumeric(Sayfa.Name) Then
            S1.Cells(Satır, 1) = Sayfa.Name
            Satır = Satır + 1
        End If
    Next
    
    S1.Range("A2:A" & Rows.Count).Sort S1.Range("A2"), xlAscending
    
    Son = S1.Cells(Rows.Count, 1).End(3).Row
    Sıra = 7
    
    For Each Sayfa In S1.Range("A2:A" & Son)
        Sheets(Sayfa.Text).Move Before:=Sheets(Sıra)
        Sıra = Sıra + 1
    Next

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("SIRALAMA_SAYFASI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Application.ScreenUpdating = True

    MsgBox "Sayısal isimli sayfalar sıralanmıştır.", vbInformation
End Sub

Teşekkür ederim Korhan Bey. Sorunum çözülmüş oldu.

hopeful · 21 Mart 2018

AHMETMANAV' Alıntı:
Sub sayfasirala()
Application.ScreenUpdating = False
Sheets.Add
ActiveSheet.Move After:=Sheets(Sheets.Count)
Set s1 = Sheets(Sheets.Count)
For a = 1 To Sheets.Count - 1
s1.Cells(a, "a") = Sheets(a).Name
s1.[a:a].Sort Key1:=s1.[a1]
deg = Sheets(a).Name
If IsNumeric(deg) = True Then deg = Val(Sheets(a).Name)
say = WorksheetFunction.Match(deg, s1.[a:a], 0)
Sheets(a).Move Before:=Sheets(say)
Next
Application.DisplayAlerts = False
s1.Delete
End Sub

Teşekkür ederim Ahmet Bey.
Sayısal sayfaları sıralayarak en başa aldı. Metin sayfalarını sona attı.

hopeful · 21 Mart 2018

alicimri' Alıntı:

Alternatif olsun.

Kod:

Sub aa()
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
For e = 1 To Sheets.Count
arr.Add Sheets(e).Name * 1 ' Burada 1 ile çarpma işlemi yapılmaz ise alınan sayfa isimlerini Metin sıralamasına sokuyor.
'Örnek 1, 11, 4, 44, 5.... gibi
Next
arr.Sort
'Büyükten Küçüğe sıralama için
'arr.Reverse
For i = 0 To Sheets.Count - 1
Sheets(CStr(arr(i))).Move Before:=Sheets(i + 1)
Next
End Sub

Teşekkür ediyorum Ali Bey.

Makronuz "Runtime error 13. Type mismatch" hatası verdi.
arr.Add Sheets(e).Name * 1

alicimri · 21 Mart 2018

Yukarıdaki #3 deki kodu değiştirdim. Kitabınızda Sayısal değer olmayan sayfa isimleride varmış.

hopeful · 21 Mart 2018

alicimri' Alıntı:
Yukarıdaki #3 deki kodu değiştirdim. Kitabınızda Sayısal değer olmayan sayfa isimleride varmış.

Aşağıdaki hatayı aldım:

Run-time error '9
Subscript out of range

If IsNumeric(Sheets(i).Name) Then

alicimri · 21 Mart 2018

Bu konuya takılmamın 1 nedeni daha önce hiç "System.Collections.ArrayList" kullanmamıştım, sizin işinizde deneme yapıyordum. 2. neden ise geçici sayfa oluşturup silmeden de sıralama yapılabilir mi diye uğraşıyorum.
Düzeltilmiş kod aşağıda

Kod:

Sub aa()
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
For e = 1 To Sheets.Count
If IsNumeric(Sheets(e).Name) Then
arr.Add Sheets(e).Name * 1
End If
Next
arr.Sort
For i = 0 To Sheets.Count - 1
If IsNumeric(Sheets(i + 1).Name) Then
Sheets(CStr(arr(i))).Move Before:=Sheets(i + 1)
Else
Sheets(i + 1).Move After:=Sheets(Sheets.Count)
End If
Next
End Sub

hopeful · 22 Mart 2018

alicimri' Alıntı:
Bu konuya takılmamın 1 nedeni daha önce hiç "System.Collections.ArrayList" kullanmamıştım, sizin işinizde deneme yapıyordum. 2. neden ise geçici sayfa oluşturup silmeden de sıralama yapılabilir mi diye uğraşıyorum.
Düzeltilmiş kod aşağıda

Kod:

Sub aa() Dim arr As Object Set arr = CreateObject("System.Collections.ArrayList") For e = 1 To Sheets.Count If IsNumeric(Sheets(e).Name) Then arr.Add Sheets(e).Name * 1 End If Next arr.Sort For i = 0 To Sheets.Count - 1 If IsNumeric(Sheets(i + 1).Name) Then Sheets(CStr(arr(i))).Move Before:=Sheets(i + 1) Else Sheets(i + 1).Move After:=Sheets(Sheets.Count) End If Next End Sub

Aşağıdaki hatayı aldı. Ayrıca numerik olmayan sayfların da yerleri değişti..

Run-Time error '-2146233086 (80131502)
Dizin aralık dışındaydı. Negatif değer olmamalı ve koleksiyonun boyutundan daha küçük olmalıdır.
Parametre adı:index

Sheets(CStr(arr(i))).Move Before:=Sheets(i + 1)

alicimri · 22 Mart 2018

Benim dosyamda normal çalışıyor. Yine olmadı ise vazgeçiyorum.

Kod:

Sub aa()
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
For e = 1 To Sheets.Count
If IsNumeric(Sheets(e).Name) Then
arr.Add Sheets(e).Name * 1
End If
Next
arr.Sort
For i = 0 To arr.Count - 1
Sheets(Sheets(CStr(arr(i))).Name).Move Before:=Sheets(i + 1)
Next
End Sub

Sayfa adı sayıdan oluşan sayfaları yan yana sıralama

hopeful

Ekli dosyalar

Korhan Ayhan

Administrator

alicimri

AHMETMANAV

hopeful

hopeful

hopeful

alicimri

hopeful

alicimri

hopeful

alicimri