• DİKKAT

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

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

uzeyir.celikel

uzeyir.celikel

Katılım
27 Aralık 2014
Mesajlar
33
Excel Vers. ve Dili
TR
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...
 
Hata veren kodunuzu görebilir miyiz ya da dosyanızı?
 
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
 
Ö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
Genişletmek için tıkla ...

Dosya ismini almadı bu şekilde
 
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.
232525
 
Ö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
Genişletmek için tıkla ...
Temp_File ismi ile kaydediyor malesef
 

Ekli dosyalar

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    13.5 KB · Görüntüleme: 4
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
 
Ö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
Genişletmek için tıkla ...
Çok Teşekkür ederim ilginiz için güzel oldu...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst