• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makroyu başka kitaptan çalıştırma (Sayfaları A-Z sıralama)

B

Bora K

Katılım
21 Ocak 2013
Mesajlar
331
Excel Vers. ve Dili
2003 Türkçe
Merhabalar
Aşağıdaki kod sayın Seyit Tiken Bey e aittir.
Kendisine teşekkür ederim.

Arkadaşlar bu kodu ben sayfalarını sıralama yapacağım kitaptan
değilde başka bir kitaptan çalıştırmak istiyorum.

"xx" kitabının modülüne bu kodu atacağım. O kitaptan
tetikleme yaptığım anda açık olan diğer kitabın "yy" in sayfaları
sıralansın istiyorum. Makroya hakim arkadaşlardan yardım bekliyorum
Teşekkür ederim.

Kod: 
Sub Auto_Open()
Dim i As Integer
Dim j As Integer
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move before:=Worksheets(i)
End If
Next j
Next i
End Sub
 
Son düzenleme:
Bu kod kendi dosyası hariç açık olan kitapların hepsinin sayfalarını sıralıyor.

kod:

Kod: 
Sub sayfasirala()
Dim dosya As String
Dim i As Integer
Dim j As Integer
dosya = ActiveWorkbook.Name
Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
If Windows(wkbk.Name).Visible = True Then
Windows(wkbk.Name).Activate
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
End If
End If
Next
Windows(dosya).Activate
End Sub
 
Halit Bey
Çok teşekkür ederim alakanız için.
Sayenizde sayfa/kitap ismi dahi yazmayacağız.
Ellerinize sağlık.

Herşey gönlünüzce olsun inşallah.
 
Merhabalar.
Sayın Halit Bey ve diğer uzmanlarımız.

2. Nolu mesajdaki makro koduna küçük bir ilave istiyorum
Şayet olabilirse çok sevinirim. Şimdiden teşekkür ederim.

Kod. Açık olan bütün kitaplardaki sayfaları A-Z şeklinde sıralıyor.
Benim isteğim ise "xx" "yy" nolu kitapları bu sıralamadan muaf tutmak.

Saygılarımla.
 
Bora K' Alıntı:
Merhabalar.
Sayın Halit Bey ve diğer uzmanlarımız.

2. Nolu mesajdaki makro koduna küçük bir ilave istiyorum
Şayet olabilirse çok sevinirim. Şimdiden teşekkür ederim.

Kod. Açık olan bütün kitaplardaki sayfaları A-Z şeklinde sıralıyor.
Benim isteğim ise "xx" "yy" nolu kitapları bu sıralamadan muaf tutmak.

Saygılarımla.
Genişletmek için tıkla ...


kod:

Kod: 
Sub sayfasirala()
Dim dosya As String
Dim i As Integer
Dim j As Integer
dosya = ActiveWorkbook.Name
Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
[COLOR=red]If wkbk.Name <> "xx" Or wkbk.Name <> "yy" Then
[/COLOR]If Windows(wkbk.Name).Visible = True Then
Windows(wkbk.Name).Activate
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
End If
[COLOR=red]End If
[/COLOR]End If
Next
Windows(dosya).Activate
End Sub
 
Halit Bey
Çok çok özür diliyorum. Lütfen mazur görün.
Ben yanlışlıkla sayfa yazmak isterken kitap yazmışım.

If wkbk.Name <> "xx" Or wkbk.Name <> "yy" Then

Kalın olan yazılara worksheets olarak değiştirdim lakin
kod çalışmadı:(
 
Merhaba,

Bu şekilde deneyin.

Kod: 
Sub sayfasirala()
 
    Dim dosya As String, i As Integer, j As Integer, wkbk As Workbook
 
    dosya = ActiveWorkbook.Name
    For Each wkbk In Application.Workbooks
        If wkbk.Name <> ActiveWorkbook.Name Then
            If Windows(wkbk.Name).Visible = True Then
                Windows(wkbk.Name).Activate
                If Worksheets.Count = 1 Then Exit Sub
                For i = 1 To Worksheets.Count - 1
                    For j = i + 1 To Worksheets.Count
                        [COLOR=blue]With Worksheets(j)[/COLOR]
                            [COLOR=red]If .Name <> "XX" And .Name <> "YY" Then[/COLOR]
                                If .Name < Worksheets(i).Name Then
                                    .Move Before:=Worksheets(i)
                                End If
                            [COLOR=red]End If[/COLOR]
                     [COLOR=blue]   End With[/COLOR]
                    Next j
                Next i
            End If
        End If
    Next wkbk
    Windows(dosya).Activate
 
End Sub

.
 
Merhaba Ömer Bey.

Sıralanması gereken sayfalarda sorun yok.
Lakin xx ve yy sayfaları Sıralamada en başta idi en sona
sıralanıyor.
sayfa sıralaması böyle iken
xx,yy. g, e, d, a, c, b
makrodan sonra böyle olsun istiyorum.
xx,yy a, b, c, d, e, g
xx yy sayfalarının her daim başta olması gerekiyor.
 
Birinci kod:

Kod: 
Sub sayfasirala1()
Dim dosya As String
Dim i As Integer
Dim j As Integer
dosya = ActiveWorkbook.Name
Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
If Windows(wkbk.Name).Visible = True Then
Windows(wkbk.Name).Activate
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
If Worksheets(i).Name = "XX" Or Worksheets(i).Name = "YY" Then
Worksheets(i).Move Before:=Worksheets(1)
Else
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
End If
Next i
End If
End If
Next
Windows(dosya).Activate
End Sub


ikinci kod :
Kod: 
Sub sayfasirala2()
Dim dosya As String
Dim i As Integer
Dim j As Integer
Dim Syf As Worksheet
Dim SayfaAd1 As String
dosya = ActiveWorkbook.Name
Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
If Windows(wkbk.Name).Visible = True Then
Windows(wkbk.Name).Activate
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
'--------------------------
say = Worksheets.Count  'sayfa sayısı
ReDim SayfaAd(say)
'sıralama yapmıyacağınız sayfa isimlerini buraya yazın
SayfaAd(1) = "XX"
SayfaAd(2) = "YY"
SayfaAd(3) = "Sayfa1"
SayfaAd(4) = "Sayfa2"
SayfaAd(5) = "Sayfa3"
'--------------------------
 
For Each Syf In Worksheets
'For r = 1 To say
For r = say To 1 Step -1
If Syf.Name = SayfaAd(r) Then
Sheets(Syf.Name).Move Before:=Sheets(1)
End If
Next
Next
End If
End If
Next
 
Windows(dosya).Activate
End Sub

Üçüncü kod :

Kod: 
 Sub sayfasirala3()
Dim dosya As String
Dim i As Integer
Dim j As Integer
dosya = ActiveWorkbook.Name
Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
If Windows(wkbk.Name).Visible = True Then
Windows(wkbk.Name).Activate
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
Worksheets("XX").Move Before:=Worksheets(1)
Worksheets("YY").Move Before:=Worksheets(1)
End If
End If
Next
Windows(dosya).Activate
End Sub
 
Çok çok teşekkür ederim Halit Bey.
Saygılarımla.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst