belirli aralığı kaydetme

[spacebar]

üstadlarım merhaba. bir sorunum var :

bir excel kitabında, sadece (A1:R150) aralığını dosya adı A1 hücresindeki isim olacak şekilde excel olarak kaydetme makro kodları nasıl yazılır.
teşekkür ederim.

 

[askm]

Sub ASKM_Seçili_Alanı_Farkli_Kaydetme()
Dim askm As Variant
Application.DisplayAlerts = False
On Error GoTo Hata
askm = Range("A1").Value & ".xlsx"
Range("A1:R150").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & askm, FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Range("A1").Select
MsgBox "Kayıt işlemi başarılı...", vbInformation, "ASKM"
Exit Sub
Hata:
MsgBox "Kayıt işlemi başarılı olamadı...", vbInformation, "ASKM"
End Sub

 

[spacebar]

üstad ilginize çok teşekkür ederim ama "kayıt işlemi başarılı olamadı" şeklinde uyarı geliyor. bir de gizlenmiş satırlar var. bu satırların gizli kalması mümkün mü acaba.
teşekkür ederim...

 

[askm]

Örnek dosya ekleyebilir misiniz?

 

[spacebar]

dosyayı ekledim.

 

[askm]

Dosyanız ektedir. Ben denedim. Çalışıyor.
Not: A1 hücresine dosya ismi verirken girilmemesi gereken bir karakter girerseniz hata verecektir.

 

[spacebar]

üstad teşekkür ederim. bu gizli satırların gizli kalması mümkün müdür acaba

 

[askm]

Kodları aşağıdaki ile değiştirin.

Sub ASKM_Seçili_Alanı_Farkli_Kaydetme()
Dim askm As Variant
Application.DisplayAlerts = False
On Error GoTo Hata
askm = Range("A1").Value & ".xlsx"
Range("A1:R150").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & askm, FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Range("A1").Select
MsgBox "Kayıt işlemi başarılı...", vbInformation, "ASKM"
Exit Sub
Hata:
MsgBox "Kayıt işlemi başarılı olamadı...", vbInformation, "ASKM"
End Sub

 

[spacebar]

teşekkür ederim. ellerinize sağlık...

 

[askm]

Rica ederim. Hayırlı akşamlar.