Kaydederken dosya yolu seçme

[myayla]

Merhabalar,
Forumda saygıdeğer üstatların yardımı ile oluşturmuş olduğumuz aşağıda yer alan kodlar sorunsuz çalışmakta, yalnız rutin işlerde kullanmaya başladıkça eksiklikler/eklemeler hasıl oluyor. Şöyle ki ; kullanılan kodun tamamı bu şekilde,

Kod: Tümünü seç

Sub Protokol_Uret()
Dim kitaba As Workbook, kitaptan As Workbook
Dim i As Integer, ssat As Integer
Dim yol As String, dosyaAdı As String
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Set kitaptan = ThisWorkbook
yol = ThisWorkbook.Path
ssat = kitaptan.Worksheets("ÖZET LİSTE").Cells(Rows.Count, "B").End(xlUp).Row

For i = 2 To ssat
    With kitaptan.Worksheets("ÖZET LİSTE")
    If .Range("E" & i).Value = "NORMAL" Then
        Set kitaba = Workbooks.Open("C:\Users\Murat\Desktop\RAPOR TASLAKLARI" & "\NORMAL.xlsx")

        
         kitaba.Worksheets("RAPOR").Range("D9").Value = .Range("I" & i).Value
        kitaba.Worksheets("RAPOR").Range("D10").Value = .Range("J" & i).Value
        kitaba.Worksheets("RAPOR").Range("G10").Value = .Range("K" & i).Value
        kitaba.Worksheets("RAPOR").Range("D11").Value = .Range("L" & i).Value
        kitaba.Worksheets("RAPOR").Range("D12").Value = .Range("M" & i).Value
        kitaba.Worksheets("RAPOR").Range("D13").Value = .Range("N" & i).Value
        kitaba.Worksheets("RAPOR").Range("L9").Value = .Range("F" & i).Value
        kitaba.Worksheets("RAPOR").Range("L10").Value = .Range("H" & i).Value
        kitaba.Worksheets("RAPOR").Range("L11").Value = .Range("G" & i).Value
        kitaba.Worksheets("RAPOR").Range("L12").Value = .Range("O" & i).Value
        
        
        
       ElseIf .Range("E" & i).Value = "HOMOZİGOT" Then

        Set kitaba = Workbooks.Open("C:\Users\Murat\Desktop\RAPOR TASLAKLARI" & "\HOMOZİGOT.xlsx")
    
          kitaba.Worksheets("RAPOR").Range("D9").Value = .Range("I" & i).Value
        kitaba.Worksheets("RAPOR").Range("D10").Value = .Range("J" & i).Value
        kitaba.Worksheets("RAPOR").Range("G10").Value = .Range("K" & i).Value
        kitaba.Worksheets("RAPOR").Range("D11").Value = .Range("L" & i).Value
        kitaba.Worksheets("RAPOR").Range("D12").Value = .Range("M" & i).Value
        kitaba.Worksheets("RAPOR").Range("D13").Value = .Range("N" & i).Value
        kitaba.Worksheets("RAPOR").Range("L9").Value = .Range("F" & i).Value
        kitaba.Worksheets("RAPOR").Range("L10").Value = .Range("H" & i).Value
        kitaba.Worksheets("RAPOR").Range("L11").Value = .Range("G" & i).Value
         kitaba.Worksheets("RAPOR").Range("L12").Value = .Range("O" & i).Value
        
      
       kitaba.Worksheets("RAPOR").Range("H22").Value = .Range("C" & i).Value
       kitaba.Worksheets("RAPOR").Range("M25").Value = .Range("C" & i).Value
      
      
      
       ElseIf .Range("E" & i).Value = "HETEROZİGOT" Then

        Set kitaba = Workbooks.Open("C:\Users\Murat\Desktop\RAPOR TASLAKLARI" & "\HETEROZİGOT.xlsx")
    
          kitaba.Worksheets("RAPOR").Range("D9").Value = .Range("I" & i).Value
        kitaba.Worksheets("RAPOR").Range("D10").Value = .Range("J" & i).Value
        kitaba.Worksheets("RAPOR").Range("G10").Value = .Range("K" & i).Value
        kitaba.Worksheets("RAPOR").Range("D11").Value = .Range("L" & i).Value
        kitaba.Worksheets("RAPOR").Range("D12").Value = .Range("M" & i).Value
        kitaba.Worksheets("RAPOR").Range("D13").Value = .Range("N" & i).Value
        kitaba.Worksheets("RAPOR").Range("L9").Value = .Range("F" & i).Value
        kitaba.Worksheets("RAPOR").Range("L10").Value = .Range("H" & i).Value
        kitaba.Worksheets("RAPOR").Range("L11").Value = .Range("G" & i).Value
         kitaba.Worksheets("RAPOR").Range("L12").Value = .Range("O" & i).Value
        
        
       kitaba.Worksheets("RAPOR").Range("H22").Value = .Range("C" & i).Value
       kitaba.Worksheets("RAPOR").Range("M25").Value = .Range("C" & i).Value
      
      
       ElseIf .Range("E" & i).Value = "COMPOUND HETEROZİGOT" Then

        Set kitaba = Workbooks.Open("C:\Users\Murat\Desktop\RAPOR TASLAKLARI" & "\COMPOUND HETEROZİGOT.xlsx")
    
          kitaba.Worksheets("RAPOR").Range("D9").Value = .Range("I" & i).Value
        kitaba.Worksheets("RAPOR").Range("D10").Value = .Range("J" & i).Value
        kitaba.Worksheets("RAPOR").Range("G10").Value = .Range("K" & i).Value
        kitaba.Worksheets("RAPOR").Range("D11").Value = .Range("L" & i).Value
        kitaba.Worksheets("RAPOR").Range("D12").Value = .Range("M" & i).Value
        kitaba.Worksheets("RAPOR").Range("D13").Value = .Range("N" & i).Value
        kitaba.Worksheets("RAPOR").Range("L9").Value = .Range("F" & i).Value
        kitaba.Worksheets("RAPOR").Range("L10").Value = .Range("H" & i).Value
        kitaba.Worksheets("RAPOR").Range("L11").Value = .Range("G" & i).Value
         kitaba.Worksheets("RAPOR").Range("L12").Value = .Range("O" & i).Value
        
        
       kitaba.Worksheets("RAPOR").Range("H22").Value = .Range("C" & i).Value
       kitaba.Worksheets("RAPOR").Range("A26").Value = .Range("C" & i).Value
       kitaba.Worksheets("RAPOR").Range("H23").Value = .Range("D" & i).Value
       kitaba.Worksheets("RAPOR").Range("D26").Value = .Range("D" & i).Value
      
      End If
          
        
      
  dosyaAdı = kitaba.Worksheets("RAPOR").Range("L9").Value & "_" & _
kitaba.Worksheets("RAPOR").Range("D9").Value
        kitaba.SaveAs yol & "\" & dosyaAdı, 56
        kitaba.Close
        
    End With
Next
On Error GoTo 0
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Revize edilmesi gereken eylem ise ;

Kod: Tümünü seç

 dosyaAdı = kitaba.Worksheets("RAPOR").Range("L9").Value & "_" & _

kitaba.Worksheets("RAPOR").Range("D9").Value

        kitaba.SaveAs yol & "\" & dosyaAdı, 56

        kitaba.Close

Bu kısımda dosyalar oluşturulduktan sonra ilgili dosya ismine göre excel sayfasının olduğu klasöre kaydedilmektedir. Bu kısımda dosyaların kaydedileceği klasörü bana sormasını istiyorum.(10+ üzeri dosya oluşturuluyor) Yani kod çalışmaya başlayınca pencere açılsın ve ben kodun oluşturduğu dosyaların hepsinin kaydedileceği klasörü seçebilme imkanım olmasını istemekteyim.

[erseldemirel]

Bu örnek kod windows iletişim kutusu açık olan excel dosyasında seçeceğiniz yola dosyayı kaydeder. Uyarlamayı deneyiniz.

Kod: Tümünü seç

Sub Kaydet()
With Application.FileDialog(msoFileDialogSaveAs)
.FilterIndex = 2 'BURADAN XLSM seçtim
.Title = "Dosyayı Kaydet"
.InitialFileName = ThisWorkbook.Name
If .Show = -1 Then
dosyaYolu = .SelectedItems(1)
Else
MsgBox "İşlem iptal edildi !"
Exit Sub
End If
End With
ThisWorkbook.SaveAs dosyaYolu
End Sub

[myayla]

Ersel bey merhaba,
Öncelikle ilginiz ve cevabınız teşekkür ederim. Yalnız oluşturulan dosyalar 1'den fazla oluyor. Kendimce uyarlamaya çalıştım ki kodlar konusunda çok da bilgim yok açıkçası:-( Yapamadım maalesef.

[erseldemirel]

şöyle yapılabilir. bu kodunuzdan önce yol = ThisWorkbook.Path yerine aşağıdaki kodlama yapılabilir. siz yol seçmiş olursunuz. tüm kitaplar döngü ile o veri yolunu kullanır.

Kod: Tümünü seç

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
Do While dlg.Show <> -1
MsgBox "Klasör seçilmedi."
Loop
yol = dlg.SelectedItems(1)

Sub Protokol_Uret()
Dim kitaba As Workbook, kitaptan As Workbook
Dim i As Integer, ssat As Integer
Dim yol As String, dosyaAdı As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set kitaptan = ThisWorkbook
'''''''''''''''''''''''''''''
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
Do While dlg.Show <> -1
MsgBox "Klasör seçilmedi."
Loop
yol = dlg.SelectedItems(1)
'''''''''''''''''''''''''''''
ssat = kitaptan.Worksheets("ÖZET LİSTE").Cells(Rows.Count, "B").End(xlUp).Row
...
...
...

[myayla]

Üstadım ne zamandır bunu halletmeye çalışıyordum. Ne desem az gerçekten muazzam olmuş. Eline emeğine sağlık diyorum.
Son bir ricam olsa durum ile ilgili,
1- Klasör seçimi için açılan pencerede eğer ki iptal dersem MsgBox "Klasör seçilmedi." bu uyarı çıkıyor. Buraya kadar sorunum yok, yalnız raporlamayı yani kodun çalışmasını istemedim diyelim pencereye iptal dediğimde kodun çalışması dursun. (İptal dediğimde kod arkada çalıştığı için klasör seçmem için ısrar ediyor.)
2- Yine klasör seçmem için açılan pencerede ola ki klasörü seçtim zannettim ama seçmeden tamam dediğimde kod çalışıyor ve dosyaları masaüstüne kaydediyor. Bu arada da şunu istesem pencerede klasör seçmeden TAMAM desem de MsgBox "Klasör seçilmedi." bu uyarı mesajı çıksa çok mu şey istemiş olurum:-(

[erseldemirel]

1) Gerekli yerlerde exit sub derseniz koddan çıkar.

Kod: Tümünü seç

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = -1 Then
yol = dlg.SelectedItems(1)
Else
MsgBox "Klasör seçilmedi."
Exit Sub
End If

2) Windows iletişim kutusu özelliği olarak otomatik olarak genelde masaüstü seçilir. Klasör seçmeden "tamam" dersenizde otomatik genelde masaüstü veya son hatırlanana kayıt yapar. Bunu araştırmak gerekir.

[myayla]

Ersel hocam, canı gönülden çok teşekkür ederim. 2. madde için artık bizde dikkat ederiz. Saygılarımı sunuyorum.

[erseldemirel]

Murat bey rica ederim benden de saygılar kolay gelsin

[Ayhan518]

excel sayfasını yeni excel dostası olarak kaydetme.xlsm

Merhaba. iş yerinde kullanmış olduğum excel dosyamda yaptığım değişikliği makro ile yeni bir excel dosyası yapıyordum ama yapılan son güncelleme sonrası kod artık çalışmıyor. çalışma sayfasını farklı bir excel dosyası olarak kaydedemiyorum. sorunun iş yerimdeki güncelleme sonrası bir güvenlik önlemimi olduğu yoksa sürüm farkı nedeniyle mi olduğunu bilemiyorum. kaydedelicek yeri ben seçmek yerine mevcut excel dosyasının olduğu yola kaydediyordu ama şimdi kaydetmek istediğim konumu seçmek için pencere açılıyor. masaüstü yada herhangi bir klasörü seçiyorum kaydet butonuna basmama rağmen kaydetmiyor. Bu konu da yardımınıza ihtiyacım var. hem kullandığım kodu hemde örnek dosyamı ekliyorum. yardımlarınız için şimdiden teşekkür ederim.

Kod: Tümünü seç

isim1 = Sheets("Genel").Range("A3").Value

    isim2 = Sheets("Genel").Range("A4").Value



      Application.DisplayAlerts = False

    Sheets("Yoklama").Select

    Sheets("Yoklama").Copy

        ActiveWorkbook.SaveAs Filename:= _

ThisWorkbook.Path & "/" & "Deneme_" & isim1 & "_" & isim2 & ".xlsx", _

        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    ActiveWindow.Close

 MsgBox "YOKLAMA İÇİN YENİ EXCEL SURETİ OLUŞTURULDU", 64

[SNNAY]

Deneyiniz.

Kod: Tümünü seç

Sub YeniDosya()
    Dim isim1 As String
    Dim isim2 As String

    isim1 = Sheets("Genel").Range("A3").Value
    isim2 = Sheets("Genel").Range("A4").Value

    Application.DisplayAlerts = False
    Sheets("Yoklama").Select
    Sheets("Yoklama").Copy

    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Deneme_" & isim1 & "_" & isim2 & ".xlsx", _
                          FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Application.DisplayAlerts = True

    MsgBox "YOKLAMA İÇİN YENİ EXCEL SURETİ OLUŞTURULDU", 64
End Sub

[Ayhan518]

İlginiz ve yardımınız için teşekkür ederim. Yazdığınız kod ile bu gün güncelledim dosyamı, istediğimiz gibi çalışıyor. Çok teşekkür ederim