İnputboxa yazılan veriyi Sayfaya yazdırmak

[metin_0606]

Değerli forum üyeleri paylaştığım makro ile inputboxa yazdığım isimle çalışma sayfamı C:\Arşiv isimli klasörün içerisine kaydediyorum. Yapmak istediğim bu makro ile aynı zamanda inputboxa yazdığım her ismi BOS isimli sayfanın A1 hücresinden başlayarak altta alta yazması. Yardımlarınız için şimdiden teşekkürler.

sub deneme()
Workbooks("Çalışma.xlsm").SaveAs "C:\Arşivler\" & Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2) & ".xlsx", 51
End sub

 

[Muzaffer Ali]

Merhaba.

Sub Test()
    Dim DosyaAdi As String
    Dim SonSatir As Integer
    DosyaAdi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2)
    If Not DosyaAdi = "" Then
        SonSatir = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(SonSatir, "A") = DosyaAdi
        Workbooks("Çalışma.xlsm").SaveAs "C:\Arşivler\" & DosyaAdi & ".xlsx", 51
    End If
End Sub

 

[metin_0606]

Merhaba.

Sub Test()
    Dim DosyaAdi As String
    Dim SonSatir As Integer
    DosyaAdi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2)
    If Not DosyaAdi = "" Then
        SonSatir = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(SonSatir, "A") = DosyaAdi
        Workbooks("Çalışma.xlsm").SaveAs "C:\Arşivler\" & DosyaAdi & ".xlsx", 51
    End If
End Sub

Sayın Muzaffer Ali bey geri dönüş için çok teşekkür ederim. Makroyu denedim makro istediğim klasörün içine istediğim isimle sayfayı kaydediyor ancak BOS isimli sayfanın A1 hücresine inputboxa yazdığım ismi yazdırmıyor

 

[metin_0606]

Merhaba.

Sub Test()
    Dim DosyaAdi As String
    Dim SonSatir As Integer
    DosyaAdi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2)
    If Not DosyaAdi = "" Then
        SonSatir = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(SonSatir, "A") = DosyaAdi
        Workbooks("Çalışma.xlsm").SaveAs "C:\Arşivler\" & DosyaAdi & ".xlsx", 51
    End If
End Sub

Muzaffer bey paylaşmış olduğunuz bu makro çalışma kitabının da ismini değiştiriyor

 

[Korhan Ayhan]

Kendinize uyarlayınız.

Option Explicit

Sub Deneme()
    Dim Klasor As String, Dosya_Adi As Variant, S1 As Worksheet, Satir As Long

    Klasor = "C:\Arşivler\"
    
    Dosya_Adi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", _
                Left:=(Application.Width / 2), Top:=(Application.Height / 2), Type:=2)
    
    If Dosya_Adi = False Or Dosya_Adi = "" Then
        MsgBox "Lütfen dosya adını giriniz!", vbCritical
        Exit Sub
    End If
    
    Set S1 = Sheets("BOS")
    
    If S1.Range("A1") = "" Then
        Satir = 1
    Else
        Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
    End If
    
    S1.Cells(Satir, 1) = Dosya_Adi
    ThisWorkbook.Sheets.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Klasor & Dosya_Adi & ".xlsx", 51
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
End Sub

 

[Muzaffer Ali]

Muzaffer bey paylaşmış olduğunuz bu makro çalışma kitabının da ismini değiştiriyor

Tekrar dener misiniz?
BOS adlı sayfanın A1 hücresine Bir başlık yazın. Dosya isimlerini A2 den itibaren alt alta yazacaktır.

Sub Test()
    Dim DosyaAdi As String
    Dim SonSatir As Integer
    DosyaAdi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2)
    If Not DosyaAdi = "" Then
        SonSatir =worksheets("BOS") Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(SonSatir, "A") = DosyaAdi
        Workbooks("Çalışma.xlsm").Savecopyas "C:\Arşivler\" & DosyaAdi & ".xlsx", 51
    End If
End Sub

 

[metin_0606]

Tekrar dener misiniz?
BOS adlı sayfanın A1 hücresine Bir başlık yazın. Dosya isimlerini A2 den itibaren alt alta yazacaktır.

Sub Test()
    Dim DosyaAdi As String
    Dim SonSatir As Integer
    DosyaAdi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", Type:=2)
    If Not DosyaAdi = "" Then
        SonSatir =worksheets("BOS") Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(SonSatir, "A") = DosyaAdi
        Workbooks("Çalışma.xlsm").Savecopyas "C:\Arşivler\" & DosyaAdi & ".xlsx", 51
    End If
End Sub

SonSatir =worksheets("BOS") Cells(Rows.Count, "A").End(xlUp).Row + 1
bu satırı kırmızı yapıp syntax error hatası veriyor

 

[metin_0606]

Kendinize uyarlayınız.

Option Explicit

Sub Deneme()
    Dim Klasor As String, Dosya_Adi As Variant, S1 As Worksheet, Satir As Long

    Klasor = "C:\Arşivler\"
   
    Dosya_Adi = Application.InputBox(Prompt:="Dosya Adı!!DIKKAT SADECE YIL YAZINIZ!!", _
                Left:=(Application.Width / 2), Top:=(Application.Height / 2), Type:=2)
   
    If Dosya_Adi = False Or Dosya_Adi = "" Then
        MsgBox "Lütfen dosya adını giriniz!", vbCritical
        Exit Sub
    End If
   
    Set S1 = Sheets("BOS")
   
    If S1.Range("A1") = "" Then
        Satir = 1
    Else
        Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
    End If
   
    S1.Cells(Satir, 1) = Dosya_Adi
    ThisWorkbook.Sheets.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Klasor & Dosya_Adi & ".xlsx", 51
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
End Sub

Teşekkür ederim Korhan hocam makro istediğim gibi çalıştı

 

[Korhan Ayhan]

Kırmızı bölümde boşluk yerine nokta yazılmamış. Boşluğu silip nokta eklerseniz o satır hata vermeyecektir.

SonSatir =worksheets("BOS") Cells(Rows.Count, "A").End(xlUp).Row + 1