TÜM SEKMELERİ TEK SAYFADA VBA İLE TOPLATMA

[üveyin]

Merhabalar,

Arkadaşlar önceliklere iyi formlar ekli dosyamda bir çalışmam var. burada çalışma kitabında yapmak istediğim şey vba kodlar ile açılmış tüm sekmeler yada eklenecek tüm sekmeleri tek sayfada mevcut işimde kulladığım düzende sadece makrolu butonlar ile toplu hale getirmek istiyorum. öncelikle vba kod yazamıyorum bunu baştan söyleyeyim araştırmalar ile kendi kullanımım için oluşturdugum vba dosyaları ile dosyalarımı daha düzenli tutmak istiyorum bu siteden de çok çok memnunum açmış olduğum tüm konuları sonuç odaklı olarak sonlandırdık inşallah bu ve benzer tüm konularda sizlerin ve hocalarımzın destegi ile tüm form ziyaretçilerinin paylaşımına da sunmuş olacagız diye düşünüyorum her zaman konuları alt tarafta başlıklar halinde yazıyorum şimdiden teşekkürü bir borç bilerek tüm destek olacaklara emekleri için tek tek teşekkürler.

*Veriler sayfamsında Vba modül2 içinde yazılı kodlar ile tüm sekmelerdeki bilgiler kopyalama ile getiriyorum buradaki sorunum kopyalarken tüm özellikler ile getiriyor ben sadece degerleri getirecek böyle bir makro ile sorunum çözülecektir

*Toplam Reçete sayfasında görevi tüm açılmış sekmeleri ve açılack sekmeleri aynı isim kodları toplasın yine veri sayfasındaki başlık ile aynı formatta yaptım. burada butonlarım var bunların üzerinde görevleri yazılı aslında butonların kayıt ve sil görev yapıyor kayıt butonundaki sorunum koyalamadaki tüm özellikleri getirmesi ben sadece degerleri getire bilen böyle bir makro ile sorunum çözülecektir

*Yeni sayfa butonum adından anlaşılacagı üzere sayfayı açarken deneme sekmesindeki formatta yeni sayfa oluştursun böyle bir makro ile sorunum çözülecektir.

*Yazdır butonu ile Toplu reçete sayfasını kaç sayfa olsada a4 sayfasına sığacak şekilde A4 satırındaki başlıkların her sayfada (üste yenilenecek satırlar) böyle bir makro ile sorunum çözülecektir.

şimdiden yadımlarınız ve emekleriniz için teşekkürü bir borç bilirim.

 

[üveyin]

merhabalar iyi forumlar,
Konu hakkında halen araştırmalarım devam etmekte ve sizlerinde yardımlarını bekliyorum dönüş ve önerileriniz için şimdiden teşekkür ediyorum

 

[Korhan Ayhan]

Yönlendirme yaparak destek olmak istedim..

Arşiv konularını incelemenizi tavsiye ederim. Bolca örnek var..

Arşiv Konuları

 

[pitchoute]

Merhaba, şu şekilde deneyip sonucu paylaşabilir misiniz? Yedek almayı lütfen unutmayın;

' Sadece Değerleri Kopyalamak İçin:
Sub SadeceDeğerleriGetir()
    Dim ws As Worksheet
    Dim hedefSayfa As Worksheet
    Dim sonSatir As Long, hedefSonSatir As Long
    
    Set hedefSayfa = Worksheets("Veriler")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> hedefSayfa.Name And ws.Name <> "Toplam Reçete" Then
            sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            hedefSonSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "A").End(xlUp).Row
            If hedefSonSatir = 1 And hedefSayfa.Range("A1").Value = "" Then
                hedefSonSatir = 0
            End If
            
            If sonSatir > 0 Then
                ws.Range("A1:Z" & sonSatir).Copy
                hedefSayfa.Range("A" & hedefSonSatir + 1).PasteSpecial xlPasteValues
            End If
        End If
    Next ws
    Application.CutCopyMode = False
    MsgBox "Tüm veriler değer formatında toplandı!", vbInformation
End Sub

' Tüm Sekmelerdeki Verileri Toplama
Sub TümSekmeleriTopla()
    Dim ws As Worksheet
    Dim toplamSayfa As Worksheet
    Dim sonSatir As Long, hedefSonSatir As Long
    Dim başlıkSatırı As Long
    
    Set toplamSayfa = Worksheets("Toplam Reçete")
    başlıkSatırı = 1
    toplamSayfa.Range("A" & başlıkSatırı + 1 & ":Z1000").Clear
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> toplamSayfa.Name And ws.Name <> "Veriler" Then
            sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            If sonSatir > başlıkSatırı Then
                hedefSonSatir = toplamSayfa.Cells(toplamSayfa.Rows.Count, "A").End(xlUp).Row
                If hedefSonSatir < başlıkSatırı Then
                    hedefSonSatir = başlıkSatırı
                End If
                
                ws.Range("A" & başlıkSatırı + 1 & ":Z" & sonSatir).Copy
                toplamSayfa.Range("A" & hedefSonSatir + 1).PasteSpecial xlPasteValues
            End If
        End If
    Next ws
    Application.CutCopyMode = False
    MsgBox "Tüm sekmelerdeki veriler 'Toplam Reçete' sayfasında toplandı!", vbInformation
End Sub

' Yeni Sayfa Oluşturma
Sub YeniSayfaOluştur()
    Dim şablonSayfa As Worksheet
    Dim yeniSayfa As Worksheet
    Dim sayfaAdı As String
    Dim sayaç As Integer
    
    Set şablonSayfa = Worksheets("Deneme")
    sayfaAdı = InputBox("Lütfen yeni sayfa adını giriniz:", "Yeni Sayfa Oluştur")
    If sayfaAdı = "" Then Exit Sub
    sayaç = 0
    On Error Resume Next
    Do
        If sayaç > 0 Then
            Set yeniSayfa = Worksheets(sayfaAdı & "_" & sayaç)
        Else
            Set yeniSayfa = Worksheets(sayfaAdı)
        End If
        
        If Err.Number = 0 Then
            sayaç = sayaç + 1
        Else
            Exit Do
        End If
        Err.Clear
    Loop
    On Error GoTo 0
    
    If sayaç > 0 Then
        sayfaAdı = sayfaAdı & "_" & sayaç
    End If
    
    şablonSayfa.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ActiveSheet.Name = sayfaAdı
    MsgBox "'" & sayfaAdı & "' adlı yeni sayfa oluşturuldu!", vbInformation
End Sub

' A4 Formatında Yazdırma
Sub A4FormatındaYazdır()
    Dim yazdırSayfa As Worksheet
    
    Set yazdırSayfa = Worksheets("Toplam Reçete")
    With yazdırSayfa.PageSetup
        .Orientation = xlPortrait 
        .PaperSize = xlPaperA4   
        .Zoom = False             
        .FitToPagesWide = 1       
        .FitToPagesTall = False   
        .PrintTitleRows = "$1:$1" 
        .CenterHorizontally = True
        .PrintGridlines = True     
        .PrintHeadings = False   
    End With
    yazdırSayfa.PrintPreview
End Sub

 

[üveyin]

pitchoute merhabalar,
İlk olarak emeklerin için teşekkür ederim. Cevabınıza geç dönüş yaptıgım için beni mazur görün lütfen, bu aralar çok yakın akrabamı kaybettim aynı zamanda bilgisayarım da yazılımsal sorunlar vardı bu sürüçte dönüş yapamadım.

1- Şablon sayfa makrosunda ilk olarak sayfa adı için açılan penceresinden sonra 2 nolu resimdeki pencere geliyor 10 defa yes butonuna tıklayarak burayı geçiyorum atladığım bir şey mi var acaba yoksa normal mi? yada makro içinde değişmem gereken bir yer mi var.



Set şablonSayfa = Worksheets("Deneme")
sayfaAdı = InputBox("Lütfen yeni sayfa adını giriniz:", "Yeni Sayfa Oluştur")
If sayfaAdı = "" Then Exit Sub
sayaç = 0
On Error Resume Next
Do
If sayaç > 0 Then
Set yeniSayfa = Worksheets(sayfaAdı & "_" & sayaç)
Else
Set yeniSayfa = Worksheets(sayfaAdı)
End If

If Err.Number = 0 Then
sayaç = sayaç + 1
Else
Exit Do
End If
Err.Clear
Loop
On Error GoTo 0

If sayaç > 0 Then
sayfaAdı = sayfaAdı & "_" & sayaç
End If

şablonSayfa.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = sayfaAdı
MsgBox "'" & sayfaAdı & "' adlı yeni sayfa oluşturuldu!", vbInformation
End Sub[/CODE]


2- Toplam reçete sayfasındaki butonlarım var aşağıdaki makro çalışınca 4 nolu resimdeki gibi kayboluyor botonların denetim biçimlerdirden tüm seçenekleri kullandığım halde bile kayboluyor.

' Tüm Sekmelerdeki Verileri Toplama
Sub TümSekmeleriTopla()
Dim ws As Worksheet
Dim toplamSayfa As Worksheet
Dim sonSatir As Long, hedefSonSatir As Long
Dim başlıkSatırı As Long

Set toplamSayfa = Worksheets("Toplam Reçete")
başlıkSatırı = 1
toplamSayfa.Range("A" & başlıkSatırı + 1 & ":Z1000").Clear

For Each ws In ThisWorkbook.Worksheets
If ws.Name <> toplamSayfa.Name And ws.Name <> "Veriler" Then
sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

If sonSatir > başlıkSatırı Then
hedefSonSatir = toplamSayfa.Cells(toplamSayfa.Rows.Count, "A").End(xlUp).Row
If hedefSonSatir < başlıkSatırı Then
hedefSonSatir = başlıkSatırı
End If

ws.Range("A" & başlıkSatırı + 1 & ":Z" & sonSatir).Copy
toplamSayfa.Range("A" & hedefSonSatir + 1).PasteSpecial xlPasteValues
End If
End If
Next ws
Application.CutCopyMode = False
MsgBox "Tüm sekmelerdeki veriler 'Toplam Reçete' sayfasında toplandı!", vbInformation
End Sub




3- Sadece Değerleri Kopyalamak İçin bu marko da ise tüm açılan sekmelerde ne varsa getiriyor ama sadece (toplam reçete sayfası) ile (deneme) sayfasını kopyalamaması gerekiyor.

' Sadece Değerleri Kopyalamak İçin
Sub SadeceDeğerleriGetir()
Dim ws As Worksheet
Dim hedefSayfa As Worksheet
Dim sonSatir As Long, hedefSonSatir As Long

Set hedefSayfa = Worksheets("Veriler")

For Each ws In ThisWorkbook.Worksheets
If ws.Name <> hedefSayfa.Name And ws.Name <> "Toplam Reçete" Then
sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
hedefSonSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "A").End(xlUp).Row
If hedefSonSatir = 1 And hedefSayfa.Range("A5").Value = "" Then
hedefSonSatir = 0
End If

If sonSatir > 0 Then
ws.Range("A5:F" & sonSatir).Copy
hedefSayfa.Range("A" & hedefSonSatir + 1).PasteSpecial xlPasteValues
End If
End If
Next ws
Application.CutCopyMode = False
MsgBox "Tüm veriler değer formatında toplandı!", vbInformation
End Sub


4- Birde toplam reçete ve veriler sayfasına değer getirirken sayfadaki satır yüksekliği yazı formatı ve satır çizgileri ile ilgili bir düzenlemede yapabilrmisiniz. marko çalıştıkdan sonra yazı boyutu satır aralarına çizgi gelebilir mi?


5- Yazdır makrosu sayfa çoğaldıkça her sayfada ilk sayfanın satır başlıkları olma gibi bir çözüm var mı?