Alıcı bazlı Listele.

[sward175]

Herkese Merhabalar,
Günlük listeyi başka dosyadan kopyalayarak bu dosyada ANA LİSTE sayfasına yapıştırıyorum.
Bu dosyada "Ana Liste Hariç Sayfaları SİL" makrosu çalışmıyor.
Bu konu hakkında yardımlarınızı rica ederim.
Saygılarımla,
sward175

 

[dEdE]

Merhaba,
Eklediğiniz dosyadaki VBA kodu sayfa silmek için değil sayfa eklemek için yazılmış.
Bu durumda ne yapmak istediğinizi anlamadım.

 

[sward175]

Sayın: dEdE , Merhaba.
Listeyi her gün yeniliyorum.
Önce "Ana Liste Hariç Sayfaları sil" makrosunu çalıştırıp sayfaları silmem gerekiyor.
Sonra "Alıcıları Sayfalara Dağıt Makrosu ile Listenin sayfalarını oluşturuyorum.
Ama Yeni listeyi oluşturduktan sonra "Ana Liste Hariç Sayfaları Sil" makrosu çalışmıyor.
Bu konuda yardım rica ediyorum.
Saygılarımla,
sward175

 

[dEdE]

Merhaba,
"...Ana Liste Hariç Sayfaları Sil" makrosu çalışmıyor. ... ifadenizden, örnek dosyanızda Ana Liste Hariç Sayfaları silen bir kod olduğunu ve bunun çalışmadığını anlıyorum ama dosyanızda böyle bir kod yok. Mevcut kod yeni sayfaları oluşturuyor.
Ana Liste isimli sayfadaki "Ana Liste Hariç sayfaları SİL" isimli butona herhangi bir kod tanımlanmamış. Zaten sayfaları silecek -tanımlanacak/atanacak- bir kod yok.
Eğer sayfaları silen ama çalışmayan bir kodunuz varsa dosyaya eklemelisiniz. Sayfaları silen bir kodunuz yoksa ve bunun yazılmasını istiyorsanız bunu da açıkça belirtmelisiniz.

Ana Liste isimli sayfa dışındaki sayfaları silmek için aşağıdaki kodu kullanabilirsiniz.

Sub SayfaSil()
    Dim Syf As Worksheet
    Application.DisplayAlerts = False
    For Each Syf In Sheets
        If Syf.Name <> "Ana Liste" Then Syf.Delete
    Next Syf
    Application.DisplayAlerts = True
End Sub

 

[sward175]

Sayın: dEdE,
Yardımınız için teşekkür ediyorum.
Kod gayet güzel çalışıyor.
Saygılarımla,
sward175

 

[sward175]

Sayın: dEdE, Günaydın.
2 konu da da yardımınızı rica etsem olur mu?
1. Ana Listeden sayfalara aktarılan tablolar. Ana listedeki satır ve sütun ölçüleri ile aynı olabilir mi?
2. Ana Liste yazıcıda A4 olarak yazdırma alanı belirlendi çoğalan sayfalar da A4 formatında yazıcıda çıksın.
saygılarımla,
sward175

 

[dEdE]

Merhaba,
Sütun genişlikleri için aşağıdaki kodu dosyanızdaki Sub Kod() isimli kodların Application.ScreenUpdating = True satırından önce yapıştırmanız yeterli olacaktır. Satır yükseklikleri standart olduğu için (Farklılık göstermediği için) ayrıca bir düzenlemeye gerek görmedim.

For i = 2 To Sheets.Count
    For j = 1 To 9
        Sheets(i).Columns(j).ColumnWidth = Sheets("Ana Liste").Columns(j).ColumnWidth
    Next j
Next

 

[sward175]

Sayın: dEdE, Merhaba.
Yardımlarınız için teşekkür ederim.
Dosya gayet doğru ve güzel olarak çalışıyor.
Vermiş olduğunuz ilave kodu da eklememe rağmen "Ana Liste" sayfasından B sütununa göre sayfalar oluşuyor, Fakat Sayfaların sütun genişlikleri Ana Liste formatında oluşmuyor.
Bu konuda yardımınızı rica ediyorum.
Saygılarımla,
sward175

 

[dEdE]

Merhaba,
#7 no.lu mesaja eklediğim kodu yanlış yere (Modul2 içindeki Sub SayfaSil( )) eklemişsiniz.
Bu kodu örnek dosyanızdaki Modul1 içindeki Sub Kod() isimli prosedürün Application.ScreenUpdating = True satırından önce yapıştırmanız gerekiyordu.

 

[sward175]

Sayın: dEdE, Tekrar Merhaba.
Haklısınız uyarınızı dikkate alarak uyguladım gayet güzel çalıştı.
Bir de Ana Liste A4 formunda ayarlı ve kağıda sığıyor. Çoğalan sayfalar da A4 sığacak şekilde oluşabilmesi için yardımınızı rica edebilir miyim ?
Sayglarımla,
sward175

 

[dEdE]

Merhaba,
Modul1 içindeki Sub Kod() isimli prosedürü silip yerine aşağıdaki kodu yapıştırarak dener misiniz?

Sub Kod()
    Application.PrintCommunication = False
    Application.ScreenUpdating = False
    Dim S1 As Worksheet
    Set S1 = Sheets("Ana Liste")
    Dim Sayfa As String
    
    For a = 2 To S1.Cells(Rows.Count, "B").End(3).Row
        Sayfa = S1.Cells(a, "B")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add
            With ActiveSheet.PageSetup
                .LeftMargin = Application.InchesToPoints(0.3)
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0.7)
                .BottomMargin = Application.InchesToPoints(0)
                .Zoom = 74
            End With
            ActiveSheet.Name = Sayfa
            Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
            S1.Range("A1:I1").Copy Range("A1")
        End If
        sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
        S1.Range(S1.Cells(a, "A"), S1.Cells(a, "I")).Copy _
        Sheets(Sayfa).Cells(sonsatır, "A")
        Sheets(Sayfa).Cells(sonsatır, "A") = sonsatır - 1
    Next a
    
    For i = 2 To Sheets.Count
        For j = 1 To 9
            Sheets(i).Columns(j).ColumnWidth = Sheets("Ana Liste").Columns(j).ColumnWidth
        Next j
    Next
    
    Application.ScreenUpdating = True
    Application.PrintCommunication = True
    Sheets(1).Select
    MsgBox " B i t t i "
End Sub

 

[sward175]

Sayın: dEdE,
Aşağıdaki şekilde hata verdi.
sward175

 

[dEdE]

Merhaba,
Sadece aşağıda yazdığım satırlar ve bunların arasında kalan satırları silecektiniz. Diğerlerine dokunmayın.
Sub Kod( )
....
End sub

İstediğiniz işlemleri yapan kodların tümü aşağıdadır.

Function SayfaVarMi(Sayfa As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub SayfaSil()
    Dim Syf As Worksheet
    Application.DisplayAlerts = False
    For Each Syf In Sheets
        If Syf.Name <> "Ana Liste" Then Syf.Delete
    Next Syf
    Application.DisplayAlerts = True
End Sub


Sub Kod() 'Sayfa Ekle
    Application.PrintCommunication = False
    Application.ScreenUpdating = False
    Dim S1 As Worksheet
    Set S1 = Sheets("Ana Liste")
    Dim Sayfa As String
    
    For a = 2 To S1.Cells(Rows.Count, "B").End(3).Row
        Sayfa = S1.Cells(a, "B")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add
            With ActiveSheet.PageSetup
                .LeftMargin = Application.InchesToPoints(0.3)
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0.7)
                .BottomMargin = Application.InchesToPoints(0)
                .Zoom = 74
            End With
            ActiveSheet.Name = Sayfa
            Sheets(Sayfa).Move After:=Sheets(Sheets.Count)
            S1.Range("A1:I1").Copy Range("A1")
        End If
        sonsatır = Sheets(Sayfa).Cells(Rows.Count, "A").End(3).Row + 1
        S1.Range(S1.Cells(a, "A"), S1.Cells(a, "I")).Copy _
        Sheets(Sayfa).Cells(sonsatır, "A")
        Sheets(Sayfa).Cells(sonsatır, "A") = sonsatır - 1
    Next a
    
    For i = 2 To Sheets.Count
        For j = 1 To 9
            Sheets(i).Columns(j).ColumnWidth = Sheets("Ana Liste").Columns(j).ColumnWidth
        Next j
    Next
    
    Application.ScreenUpdating = True
    Application.PrintCommunication = True
    Sheets(1).Select
    MsgBox " B i t t i "
End Sub

 

[sward175]

Sayın: dEdE,
Çok çok teşekkür ediyorum.
Sağ Olun Var Olun.
sward175