Farklı Kaydederken Dosya İçindeki Seçili Hücreden İsim Verme

uzeyir.celikel · 12 Aralık 2021

Dosyanın tamamını farklı kaydederken, kayıt yerini soracak ve dosya içinde seçili hücrede yazan bilgileri dosya ismine vermek istiyorum.
Farklı makrolar buldum fakat bir türlü uyarlayamadım.
Yardımcı olabilirseniz çok sevinirim...

ÖmerFaruk · 12 Aralık 2021

Forumda bolca örnek var
https://www.excel.web.tr/search/233192/?q=SaveAs&o=date

uzeyir.celikel · 12 Aralık 2021

ÖmerFaruk' Alıntı:
Forumda bolca örnek var
https://www.excel.web.tr/search/233192/?q=SaveAs&o=date

Kod yazmada yeni olduğumdan örnekleri inceledim fakat uyarlayamadım.
Hata veriyor ve istediğimi bir türlü yapamıyorum...

ÖmerFaruk · 12 Aralık 2021

Hata veren kodunuzu görebilir miyiz ya da dosyanızı?

uzeyir.celikel · 12 Aralık 2021

ÖmerFaruk' Alıntı:
Hata veren kodunuzu görebilir miyiz ya da dosyanızı?

Dosyayı kaydetmeyi becerdim galiba fakat iki eksik kaldı
Biri dosyayı kaydedeceği yeri sormuyor.
Diğeri makrolu kaydedemedim...
Çalışma dosyam ekte

ÖmerFaruk · 12 Aralık 2021

Aşağıdaki haliyle o kodları kullanabilirsin.

C++:

Option Explicit

Sub Save_As_ActiveWorkbook()
    Dim Fso As Object, Target_File As Workbook, File_Folder As Object, File_Path As String, File_Name As String
 
    Set File_Folder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin!", &H100)

    If File_Folder Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If
 
    If File_Folder = "Desktop" Or File_Folder = "Masaüstü" Then
        File_Path = Environ("UserProfile") & "\" & File_Folder & "\"
    Else
        File_Path = File_Folder.Items.Item.Path & "\"
    End If
    File_Name = Sheets(ActiveSheet.Name).Cells(1, 1).Value & ".xlsx"
    Set Fso = VBA.CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Fso.CopyFile ThisWorkbook.FullName, File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name), True
    Set Target_File = Workbooks.Open(File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name), False, False)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    Target_File.SaveAs File_Name, 51
    ActiveWorkbook.Close
    'Kill File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name)
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set Fso = Nothing
    MsgBox "Dosyanız aşağıdaki klasöre yedeklenmiştir." & vbCr & vbCr & _
           File_Name, vbInformation
End Sub

uzeyir.celikel · 12 Aralık 2021

ÖmerFaruk' Alıntı:

Aşağıdaki haliyle o kodları kullanabilirsin.

C++:

Option Explicit

Sub Save_As_ActiveWorkbook()
    Dim Fso As Object, Target_File As Workbook, File_Folder As Object, File_Path As String, File_Name As String

    Set File_Folder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin!", &H100)

    If File_Folder Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If

    If File_Folder = "Desktop" Or File_Folder = "Masaüstü" Then
        File_Path = Environ("UserProfile") & "\" & File_Folder & "\"
    Else
        File_Path = File_Folder.Items.Item.Path & "\"
    End If
    File_Name = Sheets(ActiveSheet.Name).Cells(1, 1).Value & ".xlsx"
    Set Fso = VBA.CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Fso.CopyFile ThisWorkbook.FullName, File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name), True
    Set Target_File = Workbooks.Open(File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name), False, False)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    Target_File.SaveAs File_Name, 51
    ActiveWorkbook.Close
    'Kill File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name)
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set Fso = Nothing
    MsgBox "Dosyanız aşağıdaki klasöre yedeklenmiştir." & vbCr & vbCr & _
           File_Name, vbInformation
End Sub

Dosya ismini almadı bu şekilde

ÖmerFaruk · 12 Aralık 2021

Bu kodlarınızı ben kendimde denedim ve başarılıydı.
Kodlarınızı f8 ile adımlayın.

Target_File.SaveAs File_Name, 5

Bu satıra geldiğinde (satır sarı olacak) File_Name değişkeni hangi değeri alıyor bakar mısınız? (Mouse ile File_Nam üzere gelebilir ya da Watch Window penceresine değişkeni ekleyip takip edebilirsiniz.

uzeyir.celikel · 12 Aralık 2021

ÖmerFaruk' Alıntı:
Bu kodlarınızı ben kendimde denedim ve başarılıydı.
Kodlarınızı f8 ile adımlayın.

Target_File.SaveAs File_Name, 5

Bu satıra geldiğinde (satır sarı olacak) File_Name değişkeni hangi değeri alıyor bakar mısınız? (Mouse ile File_Nam üzere gelebilir ya da Watch Window penceresine değişkeni ekleyip takip edebilirsiniz.
Ekli dosyayı görüntüle 232525

Temp_File ismi ile kaydediyor malesef

ÖmerFaruk · 13 Aralık 2021

C++:

Option Explicit

Sub Save_As_ActiveWorkbook()
    Dim Fso As Object, Target_File As Workbook, File_Folder As Object, File_Path As String, File_Name As String
 
    Set File_Folder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin!", &H100)

    If File_Folder Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If
 
    If File_Folder = "Desktop" Or File_Folder = "Masaüstü" Then
        File_Path = Environ("UserProfile") & "\" & File_Folder & "\"
    Else
        File_Path = File_Folder.Items.Item.Path & "\"
    End If
    File_Name = Sheets(ActiveSheet.Name).Cells(1, 1).Value '& ".xlsx"
    Set Fso = VBA.CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Fso.CopyFile ThisWorkbook.FullName, File_Path & File_Name & "." & Fso.GetExtensionName(ThisWorkbook.Name), True
    Set Target_File = Workbooks.Open(File_Path & File_Name & "." & Fso.GetExtensionName(ThisWorkbook.Name), False, False)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    Target_File.SaveAs File_Name, 51
    ActiveWorkbook.Close
    'Kill File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name)
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set Fso = Nothing
    MsgBox "Dosyanız aşağıdaki klasöre yedeklenmiştir." & vbCr & vbCr & _
           File_Name, vbInformation
End Sub

uzeyir.celikel · 13 Aralık 2021

ÖmerFaruk' Alıntı:

C++:

Option Explicit

Sub Save_As_ActiveWorkbook()
    Dim Fso As Object, Target_File As Workbook, File_Folder As Object, File_Path As String, File_Name As String

    Set File_Folder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin!", &H100)

    If File_Folder Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If

    If File_Folder = "Desktop" Or File_Folder = "Masaüstü" Then
        File_Path = Environ("UserProfile") & "\" & File_Folder & "\"
    Else
        File_Path = File_Folder.Items.Item.Path & "\"
    End If
    File_Name = Sheets(ActiveSheet.Name).Cells(1, 1).Value '& ".xlsx"
    Set Fso = VBA.CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Fso.CopyFile ThisWorkbook.FullName, File_Path & File_Name & "." & Fso.GetExtensionName(ThisWorkbook.Name), True
    Set Target_File = Workbooks.Open(File_Path & File_Name & "." & Fso.GetExtensionName(ThisWorkbook.Name), False, False)
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    Target_File.SaveAs File_Name, 51
    ActiveWorkbook.Close
    'Kill File_Path & "Temp_File." & Fso.GetExtensionName(ThisWorkbook.Name)
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set Fso = Nothing
    MsgBox "Dosyanız aşağıdaki klasöre yedeklenmiştir." & vbCr & vbCr & _
           File_Name, vbInformation
End Sub

Çok Teşekkür ederim ilginiz için güzel oldu...

Farklı Kaydederken Dosya İçindeki Seçili Hücreden İsim Verme

uzeyir.celikel

ÖmerFaruk

Destek Ekibi

uzeyir.celikel

ÖmerFaruk

Destek Ekibi

uzeyir.celikel

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

uzeyir.celikel

ÖmerFaruk

Destek Ekibi

uzeyir.celikel

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

uzeyir.celikel