• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çözüldü Kod Hiç Tepki Vermiyor.

Y

yesimgurol

Katılım
8 Aralık 2011
Mesajlar
964
Excel Vers. ve Dili
Excel 2016,32bit
Merhaba,
"Yesım" isimli çalışma kitabında "LİSTE" isimli sayfamda hastalarıma ait listem bulunmakla birlikte bu bilgilere göre raporlar oluşturmaktayım. Oluşturacağım rapor formatını Listedeki E sütununda yazan değere göre belirliyorum. Yani E sütununda NORMAL yazar ise bu hasta için NORMAL rapor taslağını kullanıyorum.

Aşağıda yer alan kodlarda bu listedeki E sütununda yazan değere göre ilgili rapor taslaklarımın olduğu klasörde ilgili rapor taslağına hastaların gerekli olan bilgilerini ilgili hücrelere aktarıp sonrasında belirlediğim hücre değerine göre kaydet yapıyor.

Kod: 
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("LİSTE").Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 2 To ssat
    With kitaptan.Worksheets("LİSTE")
    If .Range("E" & i).Value = "NORMAL" Then
        Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\NORMAL.xlsx")

   
           
    End If
       
        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("D9").Value = .Range("I" & i).Value
       
     
       
       
        dosyaAdı = kitaba.Worksheets("RAPOR").Range("L9").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

Lakin başka bir bilgisayarda denediğimde kodu çalıştırdığımda hiç bir tepki vermiyor. Kodlar içerisine girip F8 ile kontrol ettiğimde de herhangi bir uyarı mesajı da vermiyor.:-(
 

Ekli dosyalar

Son düzenleme:
On Error Resume Next bunu pasif edip öyle adımlayın
 
Öncelikle ilginiz için çok teşekkür ederim, Sayın maliex.
Denedim ve aşağıdaki uyarıyı alıyorum.
250428
 
Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\NORMAL.xls")

dosya yolu hatalı
 
Harikasınız Hocam, evet rapor taslağı dosya uzantısında .xls yazıyormuş onu .xlsx olarak düzeltince raporu oluşturdu ilgili klasöre kaydetti fakat bu sefer de aşağıdaki uyarıyı verdi:-(
250429
 
Tamamdır hocam, hata benden kaynaklıymış yine:-(
Sorun çözüldü sayenizde tekrar teşekkür ederim. Saygılarımla.
 
Konu ile ilgili son bir ricam olsa:-(
Şöyle ki; 1 nolu mesajımda yer alan ve aşağıdaki kısımda E sütununda NORMAL yazar ise ilgili klasörde "NORMAL.xlsx " dosyası dikkate alınarak ilgili hücrelere değerleri alıp kaydediyor.

Kod: 
If .Range("E" & i).Value = "NORMAL" Then
        Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\NORMAL.xlsx")

  
          
    End If
      
        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("D9").Value = .Range("I" & i).Value


Bu işlemi hasta raporlamada kullanmaktayım. Haliyle başka başka rapor formatları kullanıyorum.(NORMAL, YETİŞKİN, ÇOCUK v.s.) Dolayısı ile rapor formatlarımdaki değerler hepsinde aynı yerlere atanmamakta. Bu açıdan acaba E sütununda YETİŞKİN yazarsa yine ilgili klasörden YETİŞKİN.xlsx dosyası seçilsin ve yukardaki gibi ben değerleri ilgili hücrelere atasam. En azından bir tane örnek olsa ben diğer rapor formatları için uyarlarım.
 
Kod: 
If .Range("E" & i).Value = "NORMAL" Then

        Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\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("D9").Value = .Range("I" & i).Value
        
elseIf .Range("E" & i).Value = "cocuk" Then   

        Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\yetiskin.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("D9").Value = .Range("I" & i).Value
elseIf .Range("E" & i).Value = "yetiskin" Then   

        Set kitaba = Workbooks.Open("C:\Users\Yesım\Desktop\ooo" & "\yetiskin.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("D9").Value = .Range("I" & i).Value

    End If

dosya yolları vehücre atamalarını kontrol ediniz
 
Süpersiniz gerçekten Sayın maliex,
Çok teşekkür ederim ilginiz için. Saygılarımla.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst