Seçili Olmayan Sayfaları diziye almak

[hsayar]

Merhabalar

Aşağıdaki kod, seçili olan sayfaları, bir array'a atıp, hepsini birlikte yeni bir kitaba kopyalar

Sub Toplu_Sheet_Kopyala()
Dim sh As Worksheet
Dim i%, y%
Dim arrsh()
For Each sh In ActiveWindow.SelectedSheets
    ReDim Preserve arrsh(y)
    arrsh(y) = sh.Name
    y = y + 1
Next
Sheets(arrsh).Copy
End Sub

sayın fpcnin bu kodları ile seçili sayfaları diziye alıp kopyalayabiliyoruz.......
peki seçili olmayan sayfaları diziye almak mümkünmüdür?

 

[Ferhat Pazarçevirdi]

Merhabalar

Yine aynı mantık üzerinden devam edersek, aşağıdaki kod seçili olmayan sayfaları listeler ...

Option Explicit
Sub Secili_Olmayan_Sayfalar()
Dim sh As Worksheet
Dim i%, y%, x%
Dim arrsh(), arrShX()
Dim sayfalar As String
For Each sh In ActiveWindow.SelectedSheets
    ReDim Preserve arrsh(y)
    arrsh(y) = sh.Name
    y = y + 1
Next
y = 0
For Each sh In ThisWorkbook.Sheets
    For i = 0 To UBound(arrsh)
        If sh.Name = arrsh(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
[COLOR=green]'------------- MESAJ OLUŞTURMAK İÇİN -----------------[/COLOR]
For i = 0 To UBound(arrShX)
    sayfalar = arrShX(i) & vbCrLf & sayfalar
Next i
MsgBox sayfalar
[COLOR=green]'------------------------------------------------------[/COLOR]
End Sub

 

[hsayar]

teşekkür ederim hocam

 

[hsayar]

hocam bu kodların eklentide çalışması için ne yapmak lazım, çalışma kitabından çalışıyor eklnetiden çalışmıyor

 

[Ferhat Pazarçevirdi]

Eklentide (xla) tabiki çalışmaz. Kodlara dikkat ederseniz, Thisworkbook gibi bir nesne kullanıyoruz. Thisworkbook da, kodların yazılı olduğu kitap ve bu kitap da, xla olduğuna göre herhangi bir sheet bulması mümkün olmayacaktır.

Thisworkbook yerine; ya ActiveWorkbook yada prosedürü çalıştıracak şekilde bir Workbook parametresi gösterilmeli ....

 

[hsayar]

Hocam gözüm en üstteki
ActiveWindow.SelectedSheets
Satırına gitti kusura bakmayın

Option Explicit
Sub Secili_Olmayan_Sayfalar()
Dim sh As Worksheet
Dim i%, y%, x%
Dim arrsh(), arrShX()
Dim sayfalar As String
For Each sh In ActiveWindow.SelectedSheets
    ReDim Preserve arrsh(y)
    arrsh(y) = sh.Name
    y = y + 1
Next
y = 0
For Each sh In [color="green"][B]ActiveWorkbook.Sheets[/B][/color] [color="red"][B]'ThisWorkbook.Sheets[/B][/color]
    For i = 0 To UBound(arrsh)
        If sh.Name = arrsh(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
'------------- MESAJ OLUŞTURMAK İÇİN -----------------
For i = 0 To UBound(arrShX)
    sayfalar = arrShX(i) & vbCrLf & sayfalar
Next i
MsgBox sayfalar
'------------------------------------------------------
End Sub

oldu,
Artık cahillihimize verin daha yeni yeni yamaklıktan çıraklığa geçiyoruz.

 

[hsayar]

Hocam gözüm en üstteki
ActiveWindow.SelectedSheets
Satırına gitti kusura bakmayın

Option Explicit
Sub Secili_Olmayan_Sayfalar()
Dim sh As Worksheet
Dim i%, y%, x%
Dim arrsh(), arrShX()
Dim sayfalar As String
For Each sh In ActiveWindow.SelectedSheets
    ReDim Preserve arrsh(y)
    arrsh(y) = sh.Name
    y = y + 1
Next
y = 0
For Each sh In [COLOR=green][B]ActiveWorkbook.Sheets[/B][/COLOR] [COLOR=red][B]'ThisWorkbook.Sheets[/B][/COLOR]
    For i = 0 To UBound(arrsh)
        If sh.Name = arrsh(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
'------------- MESAJ OLUŞTURMAK İÇİN -----------------
For i = 0 To UBound(arrShX)
    sayfalar = arrShX(i) & vbCrLf & sayfalar
Next i
MsgBox sayfalar
'------------------------------------------------------
End Sub

oldu,
Artık cahillihimize verin daha yeni yeni yamaklıktan çıraklığa geçiyoruz.

sn fpc hocam seçili olmayanları listeler iken kitabımızdaki grafik sayfalarınıda dahil etmek mümkün olur mu?

 

[veyselemre]

sn fpc hocam seçili olmayanları listeler iken kitabımızdaki grafik sayfalarınıda dahil etmek mümkün olur mu?

Dim sh As Worksheet

satırını

Dim sh As Object

ile değiştirin.

 

[hsayar]

Aslında çözüm basitmiş ama şimdi şu sorun var;
Çalışma kitabında Çalışma Sayfası, Grafik Sayfası, Uluslararası Makro Sayfası, İletişim Kutusu sayfası buluyorsa sh nin değişken tipi ne olmalıdır?

[B][COLOR=Red]'Option Explicit[/COLOR][/B]
Sub Secili_Olmayan_Sayfalar()
On Error Resume Next
[B][COLOR=Red]'Dim sh As Sheets[/COLOR][/B]
Dim i%, y%, x%
Dim arrsh(), arrShX()
Dim sayfalar As String
For Each sh In ActiveWindow.SelectedSheets
    ReDim Preserve arrsh(y)
    arrsh(y) = sh.Name
    y = y + 1
Next
y = 0
For Each sh In ActiveWorkbook.Sheets   '.Charts  '.Worksheets 'ThisWorkbook.Sheets
    For i = 0 To UBound(arrsh)
        If sh.Name = arrsh(i) Then: x = x + 1
    Next i
    If x = 0 Then
       ReDim Preserve arrShX(y)
       arrShX(y) = sh.Name
       y = y + 1
    End If
    x = 0
Next
'------------- MESAJ OLUŞTURMAK İÇİN -----------------
For i = 0 To UBound(arrShX)
    sayfalar = arrShX(i) & vbCrLf & sayfalar
Next i
MsgBox sayfalar
'------------------------------------------------------
End Sub

İletişim Kutusu1

 

[hsayar]

Dim sh As Worksheet

satırını

Dim sh As Object

ile değiştirin.

teşekkürler hocam.