VBA İle Hem Excel Hemde PDF Olarak Farklı Kaydetme

[KYenerSelvi]

Sub Düğme1_Tıklat()
    Dim w As Long
    For w = 1 To Sheets.Count
        Sheets(w).UsedRange = Sheets(w).UsedRange.Value
    Next w
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs _
      ThisWorkbook.Path & Chr(92) & _
        Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, Chr(46)) - 1) & Format(Date, "_yyyy-mm"), _
      xlOpenXMLWorkbook
End Sub

Kod genel olarak çalışıyor fakat benim vba bilgim pek olmamasından kaynaklı düzenleme yapamıyorum.

1- Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, Chr(46)) - 1) & Format(Date, "_yyyy-mm"), _
Dosya isminin sonuna yıl ve ay ekleyerek kaydediyor ama benim istediğim; Dosya ismi yerine F8 Hücresindeki değer boşluk bırakıp F9 Hücresindeki değeri yazarak kaydetmesi.

2- İlgili excel neredeyse oraya dosyayı excel olarak kaydediyor. Şuanki hali ile makrosuz ve formülsüz farklı kaydediyor burda değişiklik istemiyorum. Sadece extra olarak PDF olarak aynı yere aynı isimlendirmeler ile kaydettirebilir miyiz acaba ?

 

[KYenerSelvi]

Eğer excel ile pdf i ayrı olarak kaydedeceği yolu da belirleyebilir isek buda süper olur tabi hocam

 

[Tevfik_Kursun]

Merhaba Arkadaş,
Dosyayı yeni bir klasör açıp içine kayıt edin ve klasörün içine Pdf adlı bir klasör oluşturup dosyayı açıp makroyu deneyiniz.
İyi çalışmalar

 

[KYenerSelvi]

Merhaba Arkadaş,
Dosyayı yeni bir klasör açıp içine kayıt edin ve klasörün içine Pdf adlı bir klasör oluşturup dosyayı açıp makroyu deneyiniz.
İyi çalışmalar

Hocam sizin kod hata veriyor ben biraz araştırarak birleştirmeler yaptım kod tam olarak istediklerimi yapıyor ama farklı kaydet yapmıyor. Makroyu çalıştırınca asıl dosya gidiyor yerine makronun sonucunu verdiği excel kalıyor.

Makroyu çalıştırınca saveas yapıp aynı dosya ile nasıl devam etmesi için bir kod düzeltmesi gerekli.

Şuan aşağıdaki kod tamamen istediklerimi yapıyor fakat farklı kaydettiği dosyaya geçip ilk çalıştığım dosyayı kapatıyor.

Private Sub Yener()
Dim sh As Worksheet
Set sh = ActiveSheet
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\" & ActiveSheet.Name
isim = sh.Range("F9").Value & " - " & sh.Range("F8").Value & " - " & Format(Now, "yyyy-mm-dd")

Dim w As Long
For w = 1 To Sheets.Count
Sheets(w).UsedRange = Sheets(w).UsedRange.Value
Next w
Application.DisplayAlerts = False
ThisWorkbook.SaveAs _
ThisWorkbook.Path & Chr(92) & _
sh.Range("F9").Value & " - " & sh.Range("F8").Value & " - " & Format(Now, "yyyy-mm-dd")

Application.Dialogs(xlDialogPrint).Show

kontrol = ds.FolderExists(yol)
If kontrol <> True Then
ds.CreateFolder yol
End If

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

ActiveWorkbook.Save
End Sub

 

[KYenerSelvi]

Kısacası Farklı kaydetme işlemlerini yapıyor fakat ana dosyamı kapatıp farklı kaydettiği excel dosyasına geçiyor. Ben sadece farklı excel dosyasını kaydetmesini istiyorum. Asıl açık olan excel dosyamda kalmak istiyorum.

 

[YUSUF44]

Aşağıdaki konuyu inceler misiniz? Benim paylaştığım dosyada istediğiniz özellikler mevcut.

Soru - Veri Doğrulamada Otomatik Tamamlama

Merhaba veri doğrulama yapıp içinde arama yapmak istedim bu kodu kullandım fakat =KAYDIR(Sayfa2!$B$1;(KAÇINCI(A5&"*";Sayfa2!$B$1:$B$15;0))-1;;EĞERSAY(Sayfa2!$B$1:$B$150;A5&"*")) A5 satırında zım yazıp aratınca zımba içeren satırların arasındaki diğer satırlarıda alıyor. Sadece zım içerenleri...

www.excel.web.tr

 

[KYenerSelvi]

Aşağıdaki konuyu inceler misiniz? Benim paylaştığım dosyada istediğiniz özellikler mevcut.

Soru - Veri Doğrulamada Otomatik Tamamlama

Merhaba veri doğrulama yapıp içinde arama yapmak istedim bu kodu kullandım fakat =KAYDIR(Sayfa2!$B$1;(KAÇINCI(A5&"*";Sayfa2!$B$1:$B$15;0))-1;;EĞERSAY(Sayfa2!$B$1:$B$150;A5&"*")) A5 satırında zım yazıp aratınca zımba içeren satırların arasındaki diğer satırlarıda alıyor. Sadece zım içerenleri...

www.excel.web.tr

Hocam farklı kaydettiği excelde formüller kalıyor. Formülsüz şekilde olması için ne yapmamız lazım

 

[YUSUF44]

İlk mesajda verdiğiniz koddan yola çıkarak

Activesheet.UsedRange = Activesheet.Usedrange.Value

satırını uygun bir yere ekleyerek deneyin.

 

[KYenerSelvi]

İlk mesajda verdiğiniz koddan yola çıkarak

Activesheet.UsedRange = Activesheet.Usedrange.Value

satırını uygun bir yere ekleyerek deneyin.

Sub xlsxyap()
    Application.DisplayAlerts = False
    Dim sPath As String
    ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value
    sPath = ThisWorkbook.Path & Application.PathSeparator & [F9] & " " & [F8] & Format(Date, " dd.m.yyyy")
    
    ThisWorkbook.SaveCopyAs sPath & ".xlsm"
    If Dir(sPath & ".xlsx") <> "" Then
        Set eski = Application.Workbooks.Open(sPath & ".xlsx")
        eski.Close
        Kill sPath & ".xlsx"
    End If
    Dim Wb As Workbook
    Set Wb = Application.Workbooks.Open(sPath & ".xlsm")
    Wb.Sheets(1).Shapes.Range(Array("Button 1")).Delete
    ActiveSheet.Shapes.Range(Array("Button 2")).Delete
    Wb.SaveAs sPath & ".xlsx", xlOpenXMLWorkbook
    Wb.Close SaveChanges:=False
    Kill sPath & ".xlsm"
    Application.DisplayAlerts = True
End Sub

Hocam kodunuz bu şekilde tam istediğim gibi oldu. Sadece bir hata alıyorum görseli aşağıda

 

[KYenerSelvi]

Hocam şuanki hali ile benim ana dosyam formüllü fakat ana dosyamıda formülsüz hale getiriyor. Ana dosyamın formüllerini bozmadan farklı kaydedeceği dosyada formül ve makronun olmaması lazım

 

[YUSUF44]

Aşağıdaki gibi deneyin. Denemeden önce yedekleme yapmayı unutmayın. Bir de kodda Button silmeyle ilgili satırları kontrol edin, gereksizse iptal edin.

Sub xlsxyap()
    Application.DisplayAlerts = False
    Dim sPath As String
    sPath = ThisWorkbook.Path & Application.PathSeparator & [F9] & " " & [F8] & Format(Date, " dd.m.yyyy")
    
    ThisWorkbook.SaveCopyAs sPath & ".xlsm"
    If Dir(sPath & ".xlsx") <> "" Then
        Set eski = Application.Workbooks.Open(sPath & ".xlsx")
        eski.Close
        Kill sPath & ".xlsx"
    End If
    Dim Wb As Workbook
    Set Wb = Application.Workbooks.Open(sPath & ".xlsm")
    For w = 1 To Wb.Sheets.Count
        Wb.Sheets(w).UsedRange = Wb.Sheets(w).UsedRange.Value
    Next w
    Wb.Sheets(1).Shapes.Range(Array("Button 1")).Delete
    'ActiveSheet.Shapes.Range(Array("Button 2")).Delete
    Wb.SaveAs sPath & ".xlsx", xlOpenXMLWorkbook
    Wb.Close SaveChanges:=False
    Kill sPath & ".xlsm"
    Application.DisplayAlerts = True
End Sub

 

[KYenerSelvi]

Aşağıdaki gibi deneyin. Denemeden önce yedekleme yapmayı unutmayın. Bir de kodda Button silmeyle ilgili satırları kontrol edin, gereksizse iptal edin.

Sub xlsxyap()
    Application.DisplayAlerts = False
    Dim sPath As String
    sPath = ThisWorkbook.Path & Application.PathSeparator & [F9] & " " & [F8] & Format(Date, " dd.m.yyyy")
   
    ThisWorkbook.SaveCopyAs sPath & ".xlsm"
    If Dir(sPath & ".xlsx") <> "" Then
        Set eski = Application.Workbooks.Open(sPath & ".xlsx")
        eski.Close
        Kill sPath & ".xlsx"
    End If
    Dim Wb As Workbook
    Set Wb = Application.Workbooks.Open(sPath & ".xlsm")
    For w = 1 To Wb.Sheets.Count
        Wb.Sheets(w).UsedRange = Wb.Sheets(w).UsedRange.Value
    Next w
    Wb.Sheets(1).Shapes.Range(Array("Button 1")).Delete
    'ActiveSheet.Shapes.Range(Array("Button 2")).Delete
    Wb.SaveAs sPath & ".xlsx", xlOpenXMLWorkbook
    Wb.Close SaveChanges:=False
    Kill sPath & ".xlsm"
    Application.DisplayAlerts = True
End Sub

Teşekkürler Hocam çalıştı.

 

[KYenerSelvi]

Hocam aşağıdaki kod tüm işlerimi görüyor fakat şöyle bir sorunum var. Ana dosyamı kaydederken içerisindeki resim ve biçimle kaydetmiyor. Ana dosyadaki logo ve yazdırma görünüm biçimi ile farklı kaydetmesi mümkün müdür.

Sub YenerExcel()
    Set HucreAraligi = Nothing
    Set sh = ActiveSheet
    Set HucreAraligi = ActiveSheet.UsedRange.Cells
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    Set Kitap = Workbooks.Add(xlWBATWorksheet)
HucreAraligi.Copy
        With Kitap.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
        Application.CutCopyMode = False
        End With

isim = sh.Range("F9").Value & " " & sh.Range("F8").Value & ".xlsx"
yol = "***"
        With Kitap
            .SaveAs Filename:=yol & isim, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
            .Close SaveChanges:=False
        End With
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
End Sub