"run time error 9 subscript out of range" hatası

[TRuNsouL]

Arkadaşlar merhaba
Sub excel_olarak()
Application.ScreenUpdating = False
ActiveSheet.Copy
With ActiveWorkbook
.SaveAs Environ("USERPROFILE") & "\Desktop\" & Sheets("Sayfa1").Range("A3").Value & ".xlsm"
.Close
End With
End Sub

Böyle bir makrom var.
Ben aktif çalışma sayfasını Sayfa1 in A3 hücresindeki adsoyada göre kaydetmeye çalışıyorum ama bu hatayı alıyorum. Yardımcı olabilir misiniz.

 

[AdemCan]

Merhaba, kodları aşağıdaki kodlar ile değiştiriniz.

Sub excel_olarak()
Application.ScreenUpdating = False
baslik = Sheets("Sayfa1").Range("A3").Value
ActiveSheet.Copy
With ActiveWorkbook
.SaveAs Environ("USERPROFILE") & "\Desktop \" & baslik & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
.Close
End With
End Sub

 

[TRuNsouL]

Hocam merhaba bir hata aldım, resim olarak ekledim.

 

[AdemCan]

Desktop klasörünün yolu farklı olabilir. Klasör yolunu kontrol ediniz, aynı kodları denedim ve hatasız kayıt yapıyor.

 

[Muzaffer Ali]

Merhaba.
Dosyanızı kaydedip kapatın, yeniden açıp deneyin.
Yine de hata verirse hangi satırda hata verdiğini söyleyin.

 

[TRuNsouL]

Hocam merhaba, .SaveAs Environ("USERPROFILE") & "\Desktop \" & baslik & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
bu satırda hata veriyor.

 

[TRuNsouL]

Desktop klasörünün yolu farklı olabilir. Klasör yolunu kontrol ediniz, aynı kodları denedim ve hatasız kayıt yapıyor.

Hocam aslında dosya yolunda dikkat ederseniz C:\Users\ab213918\Desktop\ şeklinde yol var ama İzinle alakalı bir durum olabilir mi

 

[AdemCan]

Bu satır kodun oluşturduğu yol bilgisi, bu aşamada yapmamız gereken Desktop klasörünün bilgisayardaki konumunu kontrol etmek.

 

[AdemCan]

Merhaba kayıt işlemi için kontrol satırlarını içeren şu kodları kullanabilirsiniz.

Sub excel_olarak()
Application.ScreenUpdating = False
Dim klasor As Object, kontrol As String, yol As String

Set klasor = CreateObject("Scripting.FileSystemObject")

baslik = Sheets("Sayfa1").Range("A3").Value
If baslik = Empty Then
    MsgBox "Başlık bilgisi boş olamaz!, A3 hücresine başlık bilgisini yazınız.", vbExclamation, "Uyarı"
Exit Sub
End If

yol = Environ("USERPROFILE") & "\Desktop"
kontrol = klasor.FolderExists(yol)

If kontrol = True Then
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs yol & "\" & baslik & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
        .Close
    End With
Else
    MsgBox yol & " klasörü bulunamadı!"
End If
Application.ScreenUpdating = True
End Sub

 

[TRuNsouL]

Hocam çok teşekkür ederim bu makro gayet düzgün çalıştı. Sadece aynı isimde bir excel varsa üzerine kaydetmek istiyormusunuz dediğimde hayır deyince hata veriyor. Mesela aynı isimde bir excel varsa adın sonuna 1,2 gibi isim verebilir miyiz ?