Soru Sayfayı Farklı Kaydet

[okan32]

Aşağıda vermiş olduğum kodla sayfayı farklı kaydede biliyorum. Yalnız ben son dolu satır ve son dolu sütuna kadar olan bölümü farklı kaydetmek istiyorum. Uğraştım ama yapamadım Yardımlarınız icin şimdiden teşekkür ediyorum.

Sub Farklı_kaydet()
   
    Sayfa_Adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)

If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"


On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(Dosya)
Uzanti = ".xls"


yer = Kaynak & "YKredi Aktar"

Sheets("ykredi").Select
Sheets("ykredi").Copy



Application.DisplayAlerts = False

If Uzanti = "xls" Then
FileFormatNum = -4143
ElseIf Uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

ActiveWorkbook.SaveAs yer & " " & Uzanti, FileFormat:=FileFormatNum  'Uzanti

For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Select
ActiveSheet.DrawingObjects.Delete
Next i

For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next

ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "Yapı Kredi Dosyanız Hazırlandı !", vbInformation, "DİKKAT"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[okan32]

Konu günceldir Arkadaşlar