Makro sayfa çoğaltmıyor??

[ockucukay]

Merhaba

Ben aşağıdaki kod yardımıyla şablon bir sayfadan rapor yapıyorum. Ancak makro 61 sayfa olduğunda daha fazla kopyalama yapmıyor. Benim bildiğim kadarıyla 256 sayfaya kadar yapması lazım, neden yapmadığı hakkında fikri olan var mı? Yardımcı olursanız sevinirim.

İlgili dosya ektedir. Kod:

Sub Sayfa_Ekle()

Dim blnfound As Boolean
Dim i As Integer
Dim ws As Object
Dim strListSheet As String: strListSheet = "Sevk Listesi" 'The name of the sheet that has the list.

For i = 2 To Sheets(strListSheet).Cells(Rows.Count, 1).End(xlUp).Row
blnfound = False
For Each ws In ThisWorkbook.Worksheets
If UCase(ws.Name) = UCase(CStr(Sheets(strListSheet).Cells(i, 1).Value)) Then blnfound = True
Next ws
If blnfound = False Then
Sheets("Sablon").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = Sheets(strListSheet).Cells(i, 1).Value
End If
Next i

End Sub

 

[Necdet]

Merhaba,

2010 sürümü ile denedim bir sorun çıkmadı.

 

[ockucukay]

ben 2003 office ile deniyorum. Toplam 60 sayfa olduğunda makro "Sheets("Sablon").Copy After:=Sheets(Worksheets.Count)" bu kod üstünde hata veriyor. Manuel olarak dahi sayfa kopyalayamıyorum.

 

[Necdet]

2003 sürümde 46 da kaldım ben

 

[ockucukay]

sorun ne olabilir acaba? bir fikriniz var mı necdet bey?

 

[Necdet]

Maalesef yok.

 

[ockucukay]

tüh, arkadaşlar çözümün ne olabileceği hakkında bir fikri olan var mı?

 

[ockucukay]

fikri olan?

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki linkte konu açıklanmış. İncelermisiniz.

Sayfa kopyalama

 

[Emir Hüseyin Çoban]

fikri olan?

. . .

Merhaba.
Office sürümünüzü yükseltme vakti gelmiş sanırım.

. . .

 

[uzmanamele]

Merhaba

On Error Resume Next ilavesi sorunu çözer.
ya da kopyalanacak sayfa sayısınına x dersek; y=0 koypalanan sayfadan sonra y=y+1 ve eğer if y=59 then thisworkbook save ile dosyayı kaydedin.
excel 2003 de çok fazla sayfa ekleme işlemi yapıldığında (bu örnekte 60 ama bazen farklı olabiliyor, nedendir bilmem) daha fazla sayfa eklemek için dosyayı kaydetmeniz gerekir.
bunu el ile sayfa ekleyerek de gözlemleyebilirsiniz.

 

[ockucukay]

Kodu aşağıdaki hale getirmeme rağmen ana sayfa ve şablon sayfası dahil 61 sayfayı geçemedim. Bilgisayarım İ5 işlemci ve 4 GB RAM var. Söylediğiniz kodları nereye yazmam lazım?

Sub Sayfa_Ekle()

Dim blnfound As Boolean
Dim i As Integer
Dim ws As Object
Dim strListSheet As String: strListSheet = "Sevk Listesi" 'The name of the sheet that has the list.

For i = 2 To Sheets(strListSheet).Cells(Rows.Count, 1).End(xlUp).Row
blnfound = False
For Each ws In ThisWorkbook.Worksheets
If UCase(ws.Name) = UCase(CStr(Sheets(strListSheet).Cells(i, 1).Value)) Then blnfound = True
Next ws
If blnfound = False Then
Sheets("Sablon").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = Sheets(strListSheet).Cells(i, 1).Value
ThisWorkbook.Save
End If
Next i

End Sub

Merhaba

On Error Resume Next ilavesi sorunu çözer.
ya da kopyalanacak sayfa sayısınına x dersek; y=0 koypalanan sayfadan sonra y=y+1 ve eğer if y=59 then thisworkbook save ile dosyayı kaydedin.
excel 2003 de çok fazla sayfa ekleme işlemi yapıldığında (bu örnekte 60 ama bazen farklı olabiliyor, nedendir bilmem) daha fazla sayfa eklemek için dosyayı kaydetmeniz gerekir.
bunu el ile sayfa ekleyerek de gözlemleyebilirsiniz.

 

[Korhan Ayhan]

Merhaba,

#9 nolu mesajımda verdiğim linkte gerekli açıklamalar yapılmış.

Bence sisteminizi denemek için boş bir excel sayfasını aşağıdaki kod ile kopyalamayı deneyin. Eğer sorun çıkarmadan belirttiğiniz adet sayfadan fazla ekleniyorsa bu durumda sizin dosyanızdaki ŞABLON sayfanızın yüklü olmasından dolayı istediğiniz sayıda ekleme yapamıyorsunuz demektir.

Sub SAYFA_KOPYALA()
    İLK = Time
    SAY = InputBox("Kopyalanacak sayfa sayısını giriniz...")
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    For X = 1 To SAY
        Sheets("Sayfa1").Copy After:=Sheets(Worksheets.Count)
        ActiveSheet.Name = X
        ActiveSheet.Range("A5").Value = X
    Next
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
    "İşlem süresi ; " & Format(Time - İLK, "hh:mm:ss")
End Sub

Ben işyerimdeki bilgisayarımda denedim. Boş excel sayfasından 1500 adet sayfayı yaklaşık 11 dakikada kopyaladı.
Aynı kod ile 250 adet sayfa eklemeyi denediğimde yaklaşık 17 saniyede işlemi tamamladı. 1500 sayfadaki performansla kıyasladığımızda bu sürenin 110 saniye olması gerekiyordu. Sayfa sayısı arttıkça bellek fazla kullanıldığı için bir süre sonra sistem yeterli performansı gösteremiyor. Hele ŞABLON sayfada veri varsa gerisini siz düşünün.

Sistem özellikleri;
Office 2003 Türkçe
PENTIUM-D 3,20 GHZ işlemci
2 GB RAM

Sizin işlemciniz daha yeni bir işlemci olduğu için daha rahat bir performans sergilemesi gerekiyor.

 

[ockucukay]

Merhaba Korhan hocam

Öncelikle cevabınız için teşekkür ederim. Ben verdiğiniz linki incelemiştim. Ama farklı denemeler yapmama rağmen 60 sayısını geçememiştim. Verdiğiniz koda gelince; aynı kodu bende 100 sayfa ile denedim, 16 saniyede tamamlandı. Yani boş sayfa kopyalamada sorun yok. Ama benim ihtiyacım olan sablon sayfasından kopyalama yapmak.

Dediğinizi uygulayıp sayfa üzerinde olan basit formülleri (düşeyara vb) kaldırdım ve sadece boş tablo sayfasını kopyaladım. 14 saniyede tamamlandı. Anladığım kadarıyla sorun şablon sayfasının dolu olması değil, sayfa isimlerini düzenlemek için her seferinde sevk listesi sayfasından sayfa numaralarını almasından kaynaklanıyor. Bu sorunu gidermede bana yardımcı olursanız sevinirim.

Merhaba,

#9 nolu mesajımda verdiğim linkte gerekli açıklamalar yapılmış.

Bence sisteminizi denemek için boş bir excel sayfasını aşağıdaki kod ile kopyalamayı deneyin. Eğer sorun çıkarmadan belirttiğiniz adet sayfadan fazla ekleniyorsa bu durumda sizin dosyanızdaki ŞABLON sayfanızın yüklü olmasından dolayı istediğiniz sayıda ekleme yapamıyorsunuz demektir.

Sub SAYFA_KOPYALA()
    İLK = Time
    SAY = InputBox("Kopyalanacak sayfa sayısını giriniz...")
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    For X = 1 To SAY
        Sheets("Sayfa1").Copy After:=Sheets(Worksheets.Count)
        ActiveSheet.Name = X
        ActiveSheet.Range("A5").Value = X
    Next
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
    "İşlem süresi ; " & Format(Time - İLK, "hh:mm:ss")
End Sub

Ben işyerimdeki bilgisayarımda denedim. Boş excel sayfasından 1500 adet sayfayı yaklaşık 11 dakikada kopyaladı.
Aynı kod ile 250 adet sayfa eklemeyi denediğimde yaklaşık 17 saniyede işlemi tamamladı. 1500 sayfadaki performansla kıyasladığımızda bu sürenin 110 saniye olması gerekiyordu. Sayfa sayısı arttıkça bellek fazla kullanıldığı için bir süre sonra sistem yeterli performansı gösteremiyor. Hele ŞABLON sayfada veri varsa gerisini siz düşünün.

Sistem özellikleri;
Office 2003 Türkçe
PENTIUM-D 3,20 GHZ işlemci
2 GB RAM

Sizin işlemciniz daha yeni bir işlemci olduğu için daha rahat bir performans sergilemesi gerekiyor.

 

[Korhan Ayhan]

Merhaba,

Örnek dosyanızı ekleyip ne yapmak istediğinizi açıklarmısınız.

 

[ockucukay]

Merhaba Korhan Hocam

Ekte gördiünüz dosya bir rapor hazırlama dosyası. Günlük olarak sevkiyat yapan arkadaşlar tarafından kullanılıyor. Amacımız, sevk listesi sayfasında sevk edilecek her kutu için bir numara veriliyor. Daha sonra Sablon sayfasından kopyalanan rapor formatının numarası sevk listesindeki numaralara uygun olarak değiştiriliyor. Örneğin Sevk listesinde rapor numaraları 1,2,3 olsun. Sablon sayfasından kopyalanan sayfaların numaraları da 1,2,3 olarak değiştiriliyor. Bu şekilde kutuların raporlarını geriye doğru takip edebiliyoruz. Umarım ne yapmak istediğimi anlatabilmişimdir. İlginize tekrar teşekkür ederim.

 

[ockucukay]

Arkadaşlar, yardımcı olabilecek birisi var mı acaba?

 

[uzmanamele]

Merhaba

Bu mudur?

 

[Korhan Ayhan]

Merhaba,

Bende alternatif olarak sayfa kopyalama yerine yeni sayfa ekleyip şablon sayfasının içeriğini yeni eklenen sayfaya kopyalayarak çözüm ürettim. Buradaki tek sıkıntı şablon sayfasının önizlemedeki ayarlarının yeni eklenen sayfaya uyarlanmamasıdır. Bunuda koda ekleyerek sorunu çözdüm. Fakat bu işlem kodun çalışma süresini uzatmaktadır. Bu sebeple kodun en sonuna bu işlemi yapacak bir sorgu ekledim.

Kod kısaca aşağıdaki işlemleri yapıyor.

Yeni sayfalar eklenecek. (3-5 saniye sürüyor)
Ekleme işlemi bitince size "Sayfa ayarlarını yapmak istiyor musunuz?" şeklinde bir uyarı mesajı verecek.
Bu mesaja vereceğiniz cevaba göre işlemi tamamlayacak.
Sayfa yapılarını ayarlamak benim sistemimde yaklaşık 2 dakika sürdü. Sizde süre kısalabilir. Tabi sürenin uzun ya da kısa olması sayfa sayısı ile de alakalıdır.

Ayırca eklenen sayfaları silebilmeniz içinde dosyanıza bir kod ekledim. Sayfa silme işlemi onaya bağlıdır. (Şifresi +++)

Not: Dosyanızdaki eski kodların tamamını sildim.

Uygulanan kod; (Boş modüle uygulayınız)

Dim S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, X As Integer, Say As Integer
 
Sub Sayfa_Ekle()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sablon")
    Set S2 = Sheets("Sevk Listesi")
    
    For X = 2 To S2.Cells(Rows.Count, 1).End(3).Row
        If S2.Cells(X, 1) <> "" Then
            On Error Resume Next
            Set Sayfa = Sheets(S2.Cells(X, 1).Text)
            On Error GoTo 0
            If Sayfa Is Nothing Then
                Sheets.Add , Sheets(Worksheets.Count)
                ActiveSheet.Name = S2.Cells(X, 1)
                S1.Cells.Copy Range("A1")
                Say = Say + 1
                ActiveWindow.Zoom = 75
                ActiveWindow.DisplayGridlines = False
            End If
            Set Sayfa = Nothing
        End If
    Next
    
    S2.Select
    
    If Say > 0 Then
        If MsgBox("Eklenen yeni sayfaların sayfa yapıları ayarlanacaktır!" & Chr(10) & _
        "İşlem uzun sürebilir." & Chr(10) & _
        "İşlemi onaylıyor musunuz?", vbExclamation + vbYesNo, "Dikkat !") = vbNo Then
            Set S1 = Nothing
            Set S2 = Nothing
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            Sayfa_Yapısı_Ayarla
        End If
    End If
End Sub
 
Sub Sayfa_Yapısı_Ayarla()
    Application.ScreenUpdating = False
    For X = 3 To Worksheets.Count
        With Sheets(X).PageSetup
            .PrintArea = "$A$1:$E$54"
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .LeftMargin = Application.InchesToPoints(0.748031496062992)
            .RightMargin = Application.InchesToPoints(0.31496062992126)
            .TopMargin = Application.InchesToPoints(0.15748031496063)
            .BottomMargin = Application.InchesToPoints(0.511811023622047)
            .HeaderMargin = Application.InchesToPoints(0.118110236220472)
            .FooterMargin = Application.InchesToPoints(0.433070866141732)
            .PrintHeadings = False
            .PrintGridlines = False
            .PrintComments = xlPrintNoComments
            .CenterHorizontally = False
            .CenterVertically = False
            .Orientation = xlPortrait
            .Draft = False
            .PaperSize = xlPaperA4
            .FirstPageNumber = xlAutomatic
            .Order = xlDownThenOver
            .BlackAndWhite = False
            .Zoom = 115
            .PrintErrors = xlPrintErrorsDisplayed
        End With
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Sub Sayfaları_Sil()
    Dim Onay, X As Integer
    
    Onay = Application.InputBox("Sayfaları silmek için yetkili şifresini giriniz !", "Sayfa silme işlemi")
    If Onay = False Or Onay = "" Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
    
    If Onay = "+++" Then
        Application.DisplayAlerts = False
            For X = Worksheets.Count To 3 Step -1
                Sheets(X).Delete
            Next
        Application.DisplayAlerts = True
        MsgBox "Silme işlemi tamamlanmıştır.", vbInformation
    Else
        MsgBox "Hatalı şifre girdiniz !" & Chr(10) & _
        "Lütfen daha sonra tekrar deneyiniz.", vbCritical
    End If
End Sub

 

[ockucukay]

Sayın uzmanamele

öncelikle ilginize çok teşekkürler. yaptığınız dosyayı denedim. 60.sayfadan sonra son sayfanın adı sürekli değişiyor, ta ki sevk listesindeki son sayı gelene kadar, neden böyle olduğunu anlamadım. Ama bu sınıra gelene kadar düzgün çalışıyor.

Sayın Korhan Ayhan

Emeklerinize çok teşekkür ederim. Dosyanız gayet güzel çalışıyor. Hız dert değil, makroları da koydum, ona rağmen hızında bir değişme yok.Tekrar ilginiz için teşekkür ederim.