• DİKKAT

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

Var Olan Makrolara Kısa Bir Kod Ekleme...

Y

yesimgurol

Katılım
8 Aralık 2011
Mesajlar
964
Excel Vers. ve Dili
Excel 2016,32bit
Ekte "liste" adlı dosyamda siz saygı değer hocalarımın yardımıyla oluşturmuş olduğum rapor oluşturma makroları mevcut..

"liste" adlı çalışma kitabında açıklama yapmaya çalıştım. Yardımlarınızı beklediğim mevcut kodlarımın aynı kalması koşuluyla sadece kısa bir kod eklemesi olucak.

"liste" adlı çalışma kitabındaki "H" sütununda "SU" yazar ise; "SU.xls" çalışma kitabı kullanılsın istiyorum.
İnanın yapmaya çalıştım kod sayfasından ama yapamadım:-( Şİmdiden ilginiz için teşekkür ederim.
 
Son düzenleme:
Merhaba,

Doğru mu anladım acaba?

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("Sayfa1").Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 4 To ssat
    With kitaptan.Worksheets("Sayfa1")
        If .Range("H" & i) = "SU" Then
            Set kitaba = Workbooks.Open(yol & "\" & "SU.xls")
        Else
            If .Range("D" & i).Value <= 18 Then
                Set kitaba = Workbooks.Open(yol & "\" & "ÇOCUK RAPOR FORMATI.xls")
            Else
                Set kitaba = Workbooks.Open(yol & "\" & "YETİŞKİN RAPOR FORMATI.xls")
            
            End If
        End If
        
        kitaba.Worksheets("SONUÇ HESAP").Range("B6").Value = .Range("B" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B7").Value = .Range("C" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B8").Value = .Range("E" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B9").Value = .Range("D" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D6").Value = .Range("H" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D8").Value = .Range("F" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D9").Value = .Range("G" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B12").Value = .Range("I" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B13").Value = .Range("J" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B14").Value = .Range("K" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B15").Value = .Range("L" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B16").Value = .Range("M" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B17").Value = .Range("N" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B18").Value = .Range("O" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B19").Value = .Range("P" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B20").Value = .Range("Q" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("21").Value = .Range("R" & i).Value
        dosyaAdı = kitaba.Worksheets("SONUÇ HESAP").Range("B6").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
 
Sayın ; Necdet Yeşertener
Hocam tamda istediğim gibi olmuş.Çok teşekkür ederim.İnanın çok mutlu oldum.Vaktinizi ayırdığınız saolun,iyi çalışmalar...:-)
 
Merhabalar;
Sayın Nejdet Beyin,sorunuma 2 nolu mesajında hali hazırdaki kodlara "H" sütununda "SU" kelimesi yazar ise ; rapor formatı olarak "SU.xls" kullanılsın diye kodunu eklemişti.Çok teşekkür ederim kendisine...

Bende bu eklenen kodu örnek alarak yine "H" sütununda "KAN" kelimesi yazar ise ; rapor formatı olarak "KAN.xls" kullanılsın diye kod eklemeye çalıştım ama hata verdi sanırım, en üst satır sarı renkli oldu:-(

Acaba nerede yanlış yaptım,bilemiyorum..Ben yinede dosyalarımı ekledim.Yardımcı olabilirseniz mutlu olurum.İyi çalışmalar...

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("Sayfa1").Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 4 To ssat
    With kitaptan.Worksheets("Sayfa1")
    
   [COLOR="Red"]  If .Range("H" & i) = "KAN" Then
         Set kitaba = Workbooks.Open(yol & "\" & "KAN.xls")[/COLOR]
     Else
         If .Range("H" & i) = "SU" Then
             Set kitaba = Workbooks.Open(yol & "\" & "SU.xls")
         Else
             If .Range("D" & i).Value <= 18 Then
                 Set kitaba = Workbooks.Open(yol & "\" & "ÇOCUK RAPOR FORMATI.xls")
             Else
                 Set kitaba = Workbooks.Open(yol & "\" & "YETİŞKİN RAPOR FORMATI.xls")
            
             End If
     End If
        
        kitaba.Worksheets("SONUÇ HESAP").Range("B6").Value = .Range("B" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B7").Value = .Range("C" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B8").Value = .Range("E" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B9").Value = .Range("D" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D6").Value = .Range("H" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D8").Value = .Range("F" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("D9").Value = .Range("G" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B12").Value = .Range("I" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B13").Value = .Range("J" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B14").Value = .Range("K" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B15").Value = .Range("L" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B16").Value = .Range("M" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B17").Value = .Range("N" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B18").Value = .Range("O" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B19").Value = .Range("P" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("B20").Value = .Range("Q" & i).Value
        kitaba.Worksheets("SONUÇ HESAP").Range("21").Value = .Range("R" & i).Value
        dosyaAdı = kitaba.Worksheets("SONUÇ HESAP").Range("B6").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
 
Son düzenleme:
5 nolu mesajımdaki kırmızı renkli kodu ben onun altındaki kodu örnek alarak ekledim.Fakat makro yu çalıştırdığımda kod sayfasının en üstündeki satır sarı renkli oluyor ve makro çalışmıyor:-(
Deniyorum sürekli ama bir türlü olmuyor.Acaba yanlış bir satıra mı yazıyorum kodu..:-(
 
Satırları da değitiriyorum ama yine "End With" ve En üst satır sarı renkli oluyor:-(
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst