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