Excel makro kullanarak belge kaydetme

Mumtaz55 · 27 Ekim 2024

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 · 27 Ekim 2024

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 · 28 Ekim 2024

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 · 28 Ekim 2024

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 · 28 Ekim 2024

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 · 28 Ekim 2024

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 · 28 Ekim 2024

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 · 28 Ekim 2024

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 · 30 Ekim 2024

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

pitchoute · 30 Ekim 2024

Rica ederim iyi çalışmalar

hamitalper · 30 Ekim 2024

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 · 30 Ekim 2024

Ş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 · 31 Ekim 2024

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

Biolightant · 31 Ekim 2024

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

hamitalper · 7 Kasım 2024

Biolightant' Alıntı:

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

HOCAM SAYGILAR TÜM SAYFAYI KOPYALADI

Biolightant · 7 Kasım 2024

hamitalper' Alıntı:
HOCAM SAYGILAR TÜM SAYFAYI KOPYALADI

Kodlarin ise yaramasına sevindim.
Kolay gelsin.