Tabloyu Formatlı kopyalamak

[k0081]

Merhaba arkadaşlar;

Excel Tablosunu biçimini bozmadan,, Yeni bir sayfaya commandbuton ile nasıl kopyalayabilirim ?

* Kopyalanacak tabloda hidden ( gizli sütunlar ve satırlar var.) bunlar da gelsin istemiyoruM..

* Hücre genişlikleri bozulmadan kopyalansın istiyorum.

* Tablonun görünür hali ile kopyalamak istiyorum.


Yardımcı arkadaşa şimdiden teşekkürler.

 

[Korhan Ayhan]

Sayfayı komple kopyaladıktan sonra gizli sütunları sildirip sonuca gidebilirsiniz.

 

[k0081]

Sayfayı komple kopyaladıktan sonra gizli sütunları sildirip sonuca gidebilirsiniz.

Onu denedim hocam. Fakat pratik değil.. bir de tabloyu yeni sayfaya kopyaladığımda hücre yükseklikleri aynı biçimde gelmiyor..

 

[Korhan Ayhan]

En pratik yöntemi önerdiğimi düşünüyorum.

Hangi aşamada zorlandınız...

 

[k0081]

Hocam macro kaydı ile çalışmamı seçip yeni sayfaya yapıştırıyorum ve macroyu kapatıyorum.

Çalıştırdığımda...;

Zorlandığım kısımlar;

1- Gizli olan satır ve sütunlar da geliyor..
2- Satır ve sütunların genişlikleri ve yükseklikleri aynı ölçüde olmuyor.. ( Excel in default değerleri oluyor..)

* - Yazılar ve renkler ok.

Tasarı için önerim;
Tabloyu seçeyim , mouse yardımı ile... akabinde CommandButona basıp sonucu almak..

 

[Korhan Ayhan]

Standart kopyalama işleminde satır yükseklikleri kopyalanamaz. Sütun genişlikleri kopyalanabiliyor. Bunun için döngü kurmak gerekiyor.

Tam sonuca ulaşmak için örnek dosyanızı eklermisiniz.

 

[k0081]

Dosya Ektedir hocam.


http://www.dosyayukleyin.com/do.php?id=4791]DNT_Metraj3.rar

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ActiveSheet.Copy , Worksheets(Sheets.Count)
    Set S1 = ActiveSheet
    
    For i = 14 To 6 Step -1
        If S1.Cells(107, i).Value = 0 Then
            S1.Columns(i).Delete
        End If
    Next i
    
    S1.Range("A4").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[k0081]

Hocam %80 oldu.. Yalnız ; G2 de yazan TOPLAM BOY ( METRE ) yazısı ve en alttaki G108 deki Toplam ağırlık ( 1,99 ton ) yazıları kayboluyor...

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ActiveSheet.Copy , Worksheets(Sheets.Count)
    Set S1 = ActiveSheet
    
    For i = 14 To 6 Step -1
        If S1.Cells(107, i).Value = 0 Then
            S1.Columns(i).Delete
        End If
    Next i
    
    Sutun = S1.Cells(107, S1.Columns.Count).End(1).Column
    If Sutun >= 6 Then
        S1.Cells(108, "F") = "=SUM(F107:" & S1.Cells(107, Sutun).Address(0, 0) & ")/1000"
        S1.Cells(1, Sutun + 1) = "=F108"
        S1.Cells(2, "F") = "TOPLAM BOY ( METRE )"
    End If
    
    S1.Range("A4").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[k0081]

Korhan Ayhan

Hocam çok teşekkür ediyorum Tamamdır.. Yazıyıda manuel olarak yazarım. sorun değil. Elinize-Yüreğinize sağlık. :icelim:

 

[Korhan Ayhan]

Elle yazmayın. O bölüm gözümden kaçmış.

Üstteki mesajımdaki kodu revize ettim. Tekrar deneyiniz.

 

[k0081]

Korhan Ayhan

Hocam Büyüksünüz.. Çok Teşekkürler Tamamdır.. Saygılar.

 

[k0081]

Sn. Korhan bey ;

Bu kodda şöyle bir değişiklik yapabilirmiyiz : Tabloyu kopyalarken mevcut kodlar ve butonlarda geliyor. Sadece excel tablosunun kendisini kopyalatabilirmiyiz.?

 

[Korhan Ayhan]

Deneyiniz...

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ActiveSheet.Copy , Worksheets(Sheets.Count)
    Set S1 = ActiveSheet
    
    For i = 14 To 6 Step -1
        If S1.Cells(107, i).Value = 0 Then
            S1.Columns(i).Delete
        End If
    Next i
    
    Sutun = S1.Cells(107, S1.Columns.Count).End(1).Column
    If Sutun >= 6 Then
        S1.Cells(108, "F") = "=SUM(F107:" & S1.Cells(107, Sutun).Address(0, 0) & ")/1000"
        S1.Cells(1, Sutun + 1) = "=F108"
        S1.Cells(2, "F") = "TOPLAM BOY ( METRE )"
    End If
    
    S1.DrawingObjects.Delete
    S1.Range("A4").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[k0081]

Hocam denedim. Tabloyu butonlar olmadan kopyaladı. Ama kodları da kopyaladı.

 

[Korhan Ayhan]

Deneyiniz...

Kodun hata vermemesi için makro güvenlik ayarlarından "VBA projesi nesne modeli erişimine güven" seçeneğini aktif etmeniz gerekiyor.

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, i As Integer
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ActiveSheet.Copy , Worksheets(Sheets.Count)
    Set S1 = ActiveSheet
    
    For i = 14 To 6 Step -1
        If S1.Cells(107, i).Value = 0 Then
            S1.Columns(i).Delete
        End If
    Next i
    
    Sutun = S1.Cells(107, S1.Columns.Count).End(1).Column
    If Sutun >= 6 Then
        S1.Cells(108, "F") = "=SUM(F107:" & S1.Cells(107, Sutun).Address(0, 0) & ")/1000"
        S1.Cells(1, Sutun + 1) = "=F108"
        S1.Cells(2, "F") = "TOPLAM BOY ( METRE )"
    End If
    
    S1.DrawingObjects.Delete
    
    For i = 2 To Sheets.Count
        Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(Sheets(i).Index + 1).CodeModule
        VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
    Next
    
    S1.Range("A4").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[k0081]

Korhan Ayhan

Hocam çok teşekkür ediyorum, Tamamdır.. Elinize-yüreğinize sağlık.. Mükemmel oldu..