• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

PİVOT TABLE'İ DIŞA AKTARMAK

H

hgenc545

Katılım
17 Aralık 2012
Mesajlar
133
Excel Vers. ve Dili
Microsoft 365
Merhaba,

Ekte yer alan dosyam pivotla haırlanmış, içinde loksyon sheetleri olan ve data her değiştiğinde güncellediğim bir rapor dosyası.

Bu dosyayı güncelledikten sonra pivottan çıkararak başka bir dosyaya copy past yapıyorum her sheeti, datayı da almıyorum bu yeni dosyaya. (Pivotsuz ve datasız daha düşük baytlı oluyor)
sizden ricam bunu tek bir butonla macro ile hücre formatları değişmeden sadece pivottan çıkmış halde sadece lokasyon sheetlerini olduğu gibi data sheete olmadan, hücre formatları bozulmadan(renkler, ızgaralar) otomatik olaralak bir başka dosya olarak oluşturabilirmiyiz. Yani orjinal pivot dosya kalacak(çünkü bunu her hafta tekrarlayacağım), aynı klasöre yada masa üstüne yeni bir dosya halinde pivotsuz, datasız lokasyon sheetleriyle başka bir dosya olarak kaydedilecek.

desteğiniz için şimdiden teşekkürler

dosya link
https://we.tl/t-4sHb3eXwYK
 
Aşağıdaki makro, dosyanızdaki 7 adet sayfayı orjinal dosyanızın olduğu yere "Report.xlsx" adında yeni bir çalışma kitabına, Pivot Table'lar ve Data Sheet olmadan aktarır.

Kod: 
Sub Test()
    'Haluk - 05/11/2018
    Set myFile = Workbooks.Add(xlWBATWorksheet)
    Filename = ThisWorkbook.Path & Application.PathSeparator & "Report.xlsx"
    For i = 1 To 7
        ThisWorkbook.Sheets(i).Copy After:=myFile.Sheets(myFile.Sheets.Count)
        myFile.Sheets(i + 1).Cells.Copy
        myFile.Sheets(i + 1).Cells.PasteSpecial xlValues
        myFile.Sheets(i + 1).Range("A1").Select
    Next
    Application.DisplayAlerts = False
        myFile.Sheets(1).Delete
    Application.DisplayAlerts = True
    myFile.SaveAs Filename
    myFile.Close
    showFile = MsgBox("Aktarım tamamlandı....Dosyayı görmek istiyor musunuz?", vbYesNo)
    If showFile = vbYes Then
        Workbooks.Open Filename
    Else
        Exit Sub
    End If
    Set myFile = Nothing
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Aşağıdaki makro, dosyanızdaki 7 adet sayfayı orjinal dosyanızın olduğu yere "Report.xlsx" adında yeni bir çalışma kitabına, Pivot Table'lar ve Data Sheet olmadan aktarır.

Kod: 
Sub Test()
    'Haluk - 05/11/2018
    Set myFile = Workbooks.Add(xlWBATWorksheet)
    Filename = ThisWorkbook.Path & Application.PathSeparator & "Report.xlsx"
    For i = 1 To 7
        ThisWorkbook.Sheets(i).Copy After:=myFile.Sheets(myFile.Sheets.Count)
        myFile.Sheets(i + 1).Cells.Copy
        myFile.Sheets(i + 1).Cells.PasteSpecial xlValues
        myFile.Sheets(i + 1).Range("A1").Select
    Next
    Application.DisplayAlerts = False
        myFile.Sheets(1).Delete
    Application.DisplayAlerts = True
    myFile.SaveAs Filename
    myFile.Close
    showFile = MsgBox("Aktarım tamamlandı....Dosyayı görmek istiyor musunuz?", vbYesNo)
    If showFile = vbYes Then
        Workbooks.Open Filename
    Else
        Exit Sub
    End If
    Set myFile = Nothing
End Sub

.
Genişletmek için tıkla ...
@Haluk hocam harika olmuş elinize emeğinize sağlık.
Sadece bir kaç ekleme daha yapabilirmiyiz.Yeni dosyada Hücrelerde rakamlar seperatörle ayrılmış olabilirmi?(10000değilde 10.000 gibi) ve verilerin olduğu hücrelerde ızgaralı yapma şansımız var mıdır. yani ben bir daha tek tek yaparak zaman harcamak istemiyorum. Maksat zamandan ve boyutdan tasarruf etmek ya, boyut işi tama, hücre formatlarınıda yapılandırırsak aktarırken sevinirim :) bunun içinde formül belirtirseniz sevinirim.
 
Nümerik veriler zaten orjinal dosyadaki formatına uygun olarak aktarılıyor..... Tablolardaki hücrelerin kenarlıkları yapmak için; daha önceki kodu silin ve aşağıdakini komple dosyanızdaki modüle yapıştırıp Test isimli makroyu çalıştırın.

Kod: 
Sub Test()
    'Haluk - 05/11/2018
    Set myFile = Workbooks.Add(xlWBATWorksheet)
    Filename = ThisWorkbook.Path & Application.PathSeparator & "Report.xlsx"
    For i = 1 To 7
        ThisWorkbook.Sheets(i).Activate
        Call FormatPivotTableBorders
        ThisWorkbook.Sheets(i).Copy After:=myFile.Sheets(myFile.Sheets.Count)
        myFile.Sheets(i + 1).Cells.Copy
        myFile.Sheets(i + 1).Cells.PasteSpecial xlValues
        myFile.Sheets(i + 1).Cells.PasteSpecial xlPasteFormats
        myFile.Sheets(i + 1).Range("A1").Select
    Next
    Application.DisplayAlerts = False
        myFile.Sheets(1).Delete
    Application.DisplayAlerts = True
    myFile.SaveAs Filename
    myFile.Close
    showFile = MsgBox("Aktarım tamamlandı....Dosyayı görmek istiyor musunuz?", vbYesNo)
    If showFile = vbYes Then
        Workbooks.Open Filename
    Else
        Exit Sub
    End If
    Set myFile = Nothing
End Sub
'
Private Sub FormatPivotTableBorders()
    For j = 1 To ActiveSheet.PivotTables.Count
        ActiveSheet.PivotTables(j).PivotSelect "", xlDataAndLabel, True
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection
            .HorizontalAlignment = xlRight
        End With
    Next
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Nümerik veriler zaten orjinal dosyadaki formatına uygun olarak aktarılıyor..... Tablolardaki hücrelerin kenarlıkları yapmak için; daha önceki kodu silin ve aşağıdakini komple dosyanızdaki modüle yapıştırıp Test isimli makroyu çalıştırın.

Kod: 
Sub Test()
    'Haluk - 05/11/2018
    Set myFile = Workbooks.Add(xlWBATWorksheet)
    Filename = ThisWorkbook.Path & Application.PathSeparator & "Report.xlsx"
    For i = 1 To 7
        ThisWorkbook.Sheets(i).Activate
        Call FormatPivotTableBorders
        ThisWorkbook.Sheets(i).Copy After:=myFile.Sheets(myFile.Sheets.Count)
        myFile.Sheets(i + 1).Cells.Copy
        myFile.Sheets(i + 1).Cells.PasteSpecial xlValues
        myFile.Sheets(i + 1).Cells.PasteSpecial xlPasteFormats
        myFile.Sheets(i + 1).Range("A1").Select
    Next
    Application.DisplayAlerts = False
        myFile.Sheets(1).Delete
    Application.DisplayAlerts = True
    myFile.SaveAs Filename
    myFile.Close
    showFile = MsgBox("Aktarım tamamlandı....Dosyayı görmek istiyor musunuz?", vbYesNo)
    If showFile = vbYes Then
        Workbooks.Open Filename
    Else
        Exit Sub
    End If
    Set myFile = Nothing
End Sub
'
Private Sub FormatPivotTableBorders()
    For j = 1 To ActiveSheet.PivotTables.Count
        ActiveSheet.PivotTables(j).PivotSelect "", xlDataAndLabel, True
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection
            .HorizontalAlignment = xlRight
        End With
    Next
End Sub

.
Genişletmek için tıkla ...

ustad yaptım olmadı sonuç resimdeki gibi oluyor.. Makro dosyası olarak üretiyor, sade dosya olması gerekiyor.

bu arada aşağıdaki tırnağı kaldırıyorum kodu yerleştirdikten sonra yoksa çalışmıyor... Yanlış yapıyor olabilirim destek olursanız sevinirim.
End Sub
'
Private Sub FormatPivotTableBorders()
Bu arada




1541501506772.png
 
Son düzenleme:
Haluk' Alıntı:
Ben sizin yerinize, kodları dosyanıza ekledim.

Aşağıdaki linkte verilen dosyayı indirin, masaüstüne veya bir klasöre yerleştirin. Makroları etkinleştirerek dosyayı açın, 1. sayfanın üzerindeki butona tıklayın...... o kadar.

https://drive.google.com/open?id=17yyB7gbHcRF_2pmJuoSfwk8jCqM4d01A

.
Genişletmek için tıkla ...
@Haluk hocam yordum siz ama, bende de aynısı oluyor buraya kadar her şey tamam, son olarak istediğim yeni dosyaya pivot dosyasındaki gibi hücreler biçimlenmiş gelmiyor.Bu şekilde ben yine yeni açılan dosyada tek tek her sheete girip hücre biçimlendirmesi yapmak zorunda kalıyorum, bu da işlemimi yine uzatmış oluyor, orayıda tamamlarsak tamamdır. Resimde kısaca anlatmaya çalıştım isteğimi..

1541526586228.png
 
7 No'lu mesajda verdiğim linkteki dosya bu işi tam olarak yapıyor... linkten dosyayı bir daha indirip, deneyin.

.
 
7 No'lu mesajdaki dosyada kodların çalışması sırasındaki görüntü:




.
 


Vallahi bende olmuyor, çalışmam aşağıdki gibi tamalanıyor

 
Haluk Beyin eklediği dosya aynen dediğinizi ve kendisinin gösterdiği şekilde oluyor. Herhangi bir problem yok.

Excel 2016 -İngilizce - 64 bit kullanıyorum.

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst