Excel makro kullanarak belge kaydetme

Mumtaz55 · Pazar saat 18:44'de

Merhaba 500 satırlık 6 kolonluk bir excel sayfam var. İşlerimde kolaylık sağlaması açısından bir takım formüller bulunmakta, lakin istediğim şu şekilde,

Makroyu çalıştırdığım da tüm çalışma sayfasını copy+pasta yapacak (formüllerden kurtarıp yalın veriyi yapıştırmak için)
Ardından formüllerden arındırılmış belgeyi farklı kaydet ile kaydedecek. Böyle birşey mümkün müdür acaba? Teşekkürler

pitchoute · Pazar saat 18:49'de

Yedek aldıktan sonra deneyip sonucu paylaşabilir misiniz;

Kod:

Sub CopyPasteValuesAndSaveAs()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim fname As Variant
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    ws.Copy
    Set newWb = ActiveWorkbook
    
    With newWb.Sheets(1).UsedRange
        .Value = .Value
    End With
    fname = Application.GetSaveAsFilename(InitialFileName:="Formulsuz_" & ws.Name & ".xlsx", FileFilter:="Excel Dosyaları (*.xlsx), *.xlsx")
    If fname <> False Then
        newWb.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        MsgBox "Çalışma kitabı başarıyla '" & fname & "' olarak kaydedildi.", vbInformation
    Else
        MsgBox "Kaydetme işlemi iptal edildi.", vbExclamation
    End If
    newWb.Close SaveChanges:=False
End Sub

Mumtaz55 · Pazartesi saat 09:47'de

Merhaba makro butonu ekleyip komutları yazdım. butona tıkladıgımda excel beyaz ekranda bir süre dönüyor sonra Runtime Error "7" Out Of Memory hatası ile karşılıyorum.

.Value = .Value alanı hatalı gösteriyor sanırım

pitchoute · Pazartesi saat 10:24'de

Veri çok fazla olmasından dolayı kaynaklanıyor. Şöyle deneyin;

Kod:

Sub CopyPasteValuesAndSaveAs()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim fname As Variant
    Dim lastRow As Long, lastCol As Long
    Dim rng As Range

    Set ws = ThisWorkbook.Sheets("Sayfa1")
    ws.Copy
    Set newWb = ActiveWorkbook
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error GoTo Cleanup
    
    With newWb.Sheets(1)
        lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
    End With
    
    rng.Value = rng.Value

    fname = Application.GetSaveAsFilename(InitialFileName:="Formulsuz_" & ws.Name & ".xlsx", FileFilter:="Excel Dosyaları (*.xlsx), *.xlsx")
    If fname <> False Then
        newWb.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        MsgBox "Çalışma kitabı başarıyla '" & fname & "' olarak kaydedildi.", vbInformation
    Else
        MsgBox "Kaydetme işlemi iptal edildi.", vbExclamation
    End If

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    newWb.Close SaveChanges:=False
End Sub

Mumtaz55 · Pazartesi saat 10:29'de

veri yoğunluğunu azaltmak için formüle ilave şunu da ekleyebilir miyiz Sayın Hocam?

kaydederken yalnızca;
- A ve J kolonları arasında ilk 600 satırı kaydet

pitchoute · Pazartesi saat 10:32'de

Ekleyebiliriz;

Kod:

Sub CopyPasteValuesAndSaveAs()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim fname As Variant
    Dim rngToCopy As Range
    Dim destRange As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error GoTo Cleanup

    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Set rngToCopy = ws.Range("A1:J600")
    Set newWb = Workbooks.Add(xlWBATWorksheet)
    rngToCopy.Copy
    Set destRange = newWb.Sheets(1).Range("A1")
    With destRange
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False
    fname = Application.GetSaveAsFilename(InitialFileName:="Formulsuz_" & ws.Name & ".xlsx", FileFilter:="Excel Dosyaları (*.xlsx), *.xlsx")
    If fname <> False Then
        newWb.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        MsgBox "Çalışma kitabı başarıyla '" & fname & "' olarak kaydedildi.", vbInformation
    Else
        MsgBox "Kaydetme işlemi iptal edildi.", vbExclamation
    End If

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    newWb.Close SaveChanges:=False
End Sub

Mumtaz55 · Pazartesi saat 10:55'de

hocam çok teşekkür ederim tam istediğim gibi oldu. elinize sağlık

İlave olarak şöyle birşey sorabilir miyim.. ilk formülde kaydederken uzun sürdü ama formülleri kaydedip aynı sayfa düzeninde kaydetti.
İkinci ve son verdiğiniz kod daha hızlı ve işlevsel oldu ama onda kaydettiğimde satır aralıkları, yükseklikleri orantısız kaydediyor. Sayfa aralıkları satır yükseklikleri ilk formüldeki hangi kod ile ikinci attıgınız koda ekleyebilirim??

pitchoute · Pazartesi saat 18:03'de

Merhaba, şöyle deneyin hocam;

Kod:

Sub CopyPasteValuesAndSaveAs()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim fname As Variant
    Dim rngToCopy As Range
    Dim destRange As Range
    Dim i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error GoTo Cleanup

    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Set rngToCopy = ws.Range("A1:J600")
    Set newWb = Workbooks.Add(xlWBATWorksheet)

    rngToCopy.Copy
    Set destRange = newWb.Sheets(1).Range("A1")
    With destRange
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False

    For i = 1 To rngToCopy.Columns.Count
        newWb.Sheets(1).Columns(i).ColumnWidth = ws.Columns(rngToCopy.Columns(i).Column).ColumnWidth
    Next i

    For i = 1 To rngToCopy.Rows.Count
        newWb.Sheets(1).Rows(i).RowHeight = ws.Rows(rngToCopy.Rows(i).Row).RowHeight
    Next i

    With newWb.Sheets(1).PageSetup
        .Orientation = ws.PageSetup.Orientation
        .PaperSize = ws.PageSetup.PaperSize
        .FitToPagesWide = ws.PageSetup.FitToPagesWide
        .FitToPagesTall = ws.PageSetup.FitToPagesTall
        .Zoom = False
        .LeftMargin = ws.PageSetup.LeftMargin
        .RightMargin = ws.PageSetup.RightMargin
        .TopMargin = ws.PageSetup.TopMargin
        .BottomMargin = ws.PageSetup.BottomMargin
        .HeaderMargin = ws.PageSetup.HeaderMargin
        .FooterMargin = ws.PageSetup.FooterMargin
        .PrintArea = ws.PageSetup.PrintArea
        .CenterHorizontally = ws.PageSetup.CenterHorizontally
        .CenterVertically = ws.PageSetup.CenterVertically
    End With

    fname = Application.GetSaveAsFilename(InitialFileName:="Formulsuz_" & ws.Name & ".xlsx", FileFilter:="Excel Dosyaları (*.xlsx), *.xlsx")
    If fname <> False Then
        newWb.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        MsgBox "Çalışma kitabı başarıyla '" & fname & "' olarak kaydedildi.", vbInformation
    Else
        MsgBox "Kaydetme işlemi iptal edildi.", vbExclamation
    End If

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    newWb.Close SaveChanges:=False
End Sub

Mumtaz55 · Çarşamba saat 09:03'de

Teşekkürler hocam tam istediğim gibi oldu

pitchoute · Çarşamba saat 09:32'de

Rica ederim iyi çalışmalar

hamitalper · Çarşamba saat 11:11'de

Merhaba hocam emeğinize sağlık öncelikle çok teşekkürler, aktarım yaparken grafikleri kopyalamıyor bunun için bir alternatif çözüm varmı

pitchoute · Çarşamba saat 22:33'de

Şu şekilde deneyin hocam;

Kod:

Sub CopyPasteValuesAndSaveAs()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim fname As Variant
    Dim rngToCopy As Range
    Dim destSheet As Worksheet
    Dim i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error GoTo Cleanup

    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Set rngToCopy = ws.Range("A1:J600")
    Set newWb = Workbooks.Add(xlWBATWorksheet)
    Set destSheet = newWb.Sheets(1)

    rngToCopy.Copy
    With destSheet.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False

    destSheet.Range("A1:J600").ColumnWidth = ws.Range("A1:J600").ColumnWidth
    destSheet.Range("A1:J600").RowHeight = ws.Range("A1:J600").RowHeight

    With destSheet.PageSetup
        .Orientation = ws.PageSetup.Orientation
        .PaperSize = ws.PageSetup.PaperSize
        .FitToPagesWide = ws.PageSetup.FitToPagesWide
        .FitToPagesTall = ws.PageSetup.FitToPagesTall
        .Zoom = False
        .LeftMargin = ws.PageSetup.LeftMargin
        .RightMargin = ws.PageSetup.RightMargin
        .TopMargin = ws.PageSetup.TopMargin
        .BottomMargin = ws.PageSetup.BottomMargin
        .HeaderMargin = ws.PageSetup.HeaderMargin
        .FooterMargin = ws.PageSetup.FooterMargin
        .PrintArea = ws.PageSetup.PrintArea
        .CenterHorizontally = ws.PageSetup.CenterHorizontally
        .CenterVertically = ws.PageSetup.CenterVertically
    End With

    Dim shp As Shape
    For Each shp In ws.Shapes
        If Not Intersect(shp.TopLeftCell, rngToCopy) Is Nothing Then
            shp.Copy
            destSheet.Paste
            With destSheet.Shapes(destSheet.Shapes.Count)
                .Top = shp.Top
                .Left = shp.Left
                .Height = shp.Height
                .Width = shp.Width
            End With
        End If
    Next shp

    fname = Application.GetSaveAsFilename(InitialFileName:="Formulsuz_" & ws.Name & ".xlsx", FileFilter:="Excel Dosyaları (*.xlsx), *.xlsx")
    If fname <> False Then
        newWb.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        MsgBox "Çalışma kitabı başarıyla '" & fname & "' olarak kaydedildi.", vbInformation
    Else
        MsgBox "Kaydetme işlemi iptal edildi.", vbExclamation
    End If

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

hamitalper · Dün 14:53 da

Dönüşünüz için teşekkürler Hocam, denedim ama grafikler, Şekiller ve metin kutuları olan görselleri kopyalamıyor malesef

Biolightant · Dün 20:37 da

Merhaba,
Alternatif kod olarak.

Fazla veri içeren sayfada
Kopyala + Özel yapıştır + Değerleri
Problem yaratıyor mu, kontrol edermisin.

Test edip geri dönüş yaparmısınız.

C++:

Sub FormulsuzSayfa()
    Dim RaporYolAd As String
    RaporYolAd = ActiveWorkbook.Path & "\Rapor.xlsx"
  
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=RaporYolAd, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    ActiveWorkbook.Close SaveChanges:=False
    Application.ScreenUpdating = True
  
    MsgBox "Rapor Oluşturuldu.", vbInformation, "Rapor OK"
End Sub