• DİKKAT

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

Makro taşımak

muratgunay48

muratgunay48

Altın Üye
Katılım
10 Şubat 2010
Mesajlar
1,509
Excel Vers. ve Dili
Office 365 - Türkçe (64 bit)
Arkadaşlar, sayın hocalarım, sorunun benzerini daha önce sormuştum ama daha basit olacak. Yapay zekaya yazdırdım. Ama sürekli hata veriyor.
Masaüstünde sablon.xlsm dosyasının "Makro" adlı sayfası kod bölümünden kodu alacak, yine masaüstü test.xlsx adlı dosyanın "Sayfa1" adlı sayfası kod bölümüne yapıştıracak ve masaüstüne test2.xlsm olarak kaydedecek. Böyle anlattım. Hata nerede acaba.
Şimdiden teşekkür ederim.
Saygılarımla.


Kod: 
Sub SayfaKoduKopyalaYapistir()

    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim kaynakKod As String
    
    Dim masaustu As String
    masaustu = Environ("USERPROFILE") & "\Desktop\"
    
    ' Dosyaları aç
    Set wbKaynak = Workbooks.Open(masaustu & "sablon.xlsm")
    Set wbHedef = Workbooks.Open(masaustu & "test.xlsx")
    
    ' Kaynak sayfanın CodeName'ini bul
    Dim kaynakCodeName As String
    kaynakCodeName = wbKaynak.Worksheets("Makro").CodeName
    
    ' Hedef sayfanın CodeName'ini bul
    Dim hedefCodeName As String
    hedefCodeName = wbHedef.Worksheets("Sayfa1").CodeName
    
    ' Kaynak kodu al
    With wbKaynak.VBProject.VBComponents(kaynakCodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
    
    ' Hedef kodu temizle ve yapıştır
    With wbHedef.VBProject.VBComponents(hedefCodeName).CodeModule
        .DeleteLines 1, .CountOfLines
        .AddFromString kaynakKod
    End With
    
    ' XLSM olarak kaydet
    wbHedef.SaveAs Filename:=masaustu & "test2.xlsm", _
                   FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    wbKaynak.Close False
    wbHedef.Close True

    MsgBox "Tamamlandı"

End Sub
 
Kod: 
Sub SayfaKoduKopyalaYapistir()

    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim kaynakKod As String
    Dim masaustu As String
    Dim kaynakCodeName As String
    Dim hedefCodeName As String
    Dim hedefDosya As String
   
    masaustu = Environ$("USERPROFILE") & "\Desktop\"
    hedefDosya = masaustu & "test2.xlsm"
   
    Set wbKaynak = Workbooks.Open(masaustu & "sablon.xlsm")
    Set wbHedef = Workbooks.Open(masaustu & "test.xlsx")  
   
    Application.DisplayAlerts = False
    If Dir(hedefDosya) <> "" Then Kill hedefDosya
   
    wbHedef.SaveAs Filename:=hedefDosya, _
                   FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
   
    kaynakCodeName = wbKaynak.Worksheets("Makro").CodeName
    hedefCodeName = wbHedef.Worksheets("Sayfa1").CodeName
   
    With wbKaynak.VBProject.VBComponents(kaynakCodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
   
    With wbHedef.VBProject.VBComponents(hedefCodeName).CodeModule
        If .CountOfLines > 0 Then
            .DeleteLines 1, .CountOfLines
        End If
        .AddFromString kaynakKod
    End With
   
    wbHedef.Save
    wbKaynak.Close False
    wbHedef.Close True
   

End Sub

Birde böyle deneyiniz.Hata veriyorsa hata mesajını paylaşınız
 
muhasebeciyiz' Alıntı:
Kod: 
Sub SayfaKoduKopyalaYapistir()

    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim kaynakKod As String
    Dim masaustu As String
    Dim kaynakCodeName As String
    Dim hedefCodeName As String
    Dim hedefDosya As String
  
    masaustu = Environ$("USERPROFILE") & "\Desktop\"
    hedefDosya = masaustu & "test2.xlsm"
  
    Set wbKaynak = Workbooks.Open(masaustu & "sablon.xlsm")
    Set wbHedef = Workbooks.Open(masaustu & "test.xlsx") 
  
    Application.DisplayAlerts = False
    If Dir(hedefDosya) <> "" Then Kill hedefDosya
  
    wbHedef.SaveAs Filename:=hedefDosya, _
                   FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
  
    kaynakCodeName = wbKaynak.Worksheets("Makro").CodeName
    hedefCodeName = wbHedef.Worksheets("Sayfa1").CodeName
  
    With wbKaynak.VBProject.VBComponents(kaynakCodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
  
    With wbHedef.VBProject.VBComponents(hedefCodeName).CodeModule
        If .CountOfLines > 0 Then
            .DeleteLines 1, .CountOfLines
        End If
        .AddFromString kaynakKod
    End With
  
    wbHedef.Save
    wbKaynak.Close False
    wbHedef.Close True
  

End Sub

Birde böyle deneyiniz.Hata veriyorsa hata mesajını paylaşınız
Genişletmek için tıkla ...
Deneyip sonucu yazacağım hocam. Teşekkür ederim 🙏
 
muhasebeciyiz' Alıntı:
Kod: 
Sub SayfaKoduKopyalaYapistir()

    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim kaynakKod As String
    Dim masaustu As String
    Dim kaynakCodeName As String
    Dim hedefCodeName As String
    Dim hedefDosya As String
  
    masaustu = Environ$("USERPROFILE") & "\Desktop\"
    hedefDosya = masaustu & "test2.xlsm"
  
    Set wbKaynak = Workbooks.Open(masaustu & "sablon.xlsm")
    Set wbHedef = Workbooks.Open(masaustu & "test.xlsx") 
  
    Application.DisplayAlerts = False
    If Dir(hedefDosya) <> "" Then Kill hedefDosya
  
    wbHedef.SaveAs Filename:=hedefDosya, _
                   FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
  
    kaynakCodeName = wbKaynak.Worksheets("Makro").CodeName
    hedefCodeName = wbHedef.Worksheets("Sayfa1").CodeName
  
    With wbKaynak.VBProject.VBComponents(kaynakCodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
  
    With wbHedef.VBProject.VBComponents(hedefCodeName).CodeModule
        If .CountOfLines > 0 Then
            .DeleteLines 1, .CountOfLines
        End If
        .AddFromString kaynakKod
    End With
  
    wbHedef.Save
    wbKaynak.Close False
    wbHedef.Close True
  

End Sub

Birde böyle deneyiniz.Hata veriyorsa hata mesajını paylaşınız
Genişletmek için tıkla ...
Hocam böyle bir hata alıyorum.
 

Ekli dosyalar

  • Ekran görüntüsü 2026-04-25 142431.png
    Ekran görüntüsü 2026-04-25 142431.png
    186.1 KB · Görüntüleme: 2
muhasebeciyiz' Alıntı:
Kod: 
Sub SayfaKoduKopyalaYapistir()

    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim kaynakKod As String
    Dim masaustu As String
    Dim kaynakCodeName As String
    Dim hedefCodeName As String
    Dim hedefDosya As String
  
    masaustu = Environ$("USERPROFILE") & "\Desktop\"
    hedefDosya = masaustu & "test2.xlsm"
  
    Set wbKaynak = Workbooks.Open(masaustu & "sablon.xlsm")
    Set wbHedef = Workbooks.Open(masaustu & "test.xlsx") 
  
    Application.DisplayAlerts = False
    If Dir(hedefDosya) <> "" Then Kill hedefDosya
  
    wbHedef.SaveAs Filename:=hedefDosya, _
                   FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
  
    kaynakCodeName = wbKaynak.Worksheets("Makro").CodeName
    hedefCodeName = wbHedef.Worksheets("Sayfa1").CodeName
  
    With wbKaynak.VBProject.VBComponents(kaynakCodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
  
    With wbHedef.VBProject.VBComponents(hedefCodeName).CodeModule
        If .CountOfLines > 0 Then
            .DeleteLines 1, .CountOfLines
        End If
        .AddFromString kaynakKod
    End With
  
    wbHedef.Save
    wbKaynak.Close False
    wbHedef.Close True
  

End Sub

Birde böyle deneyiniz.Hata veriyorsa hata mesajını paylaşınız
Genişletmek için tıkla ...
Hocam tekrar yazdırdım. Bu şekilde oldu sanki. Siz de bakabilir misiniz?

Kod: 
Sub KodKopyalaVeKaydetKesinCozum()
    Dim kaynakDosya As String, hedefDosya As String, yeniDosya As String
    Dim desktopPath As String
    Dim wbKaynak As Workbook, wbHedef As Workbook
    Dim kaynakKod As String
    
    ' Masaüstü yolunu al
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    
    ' Dosya yollarını tanımla (sablon olarak güncellendi)
    kaynakDosya = desktopPath & "sablon.xlsm"
    hedefDosya = desktopPath & "test.xlsx"
    yeniDosya = desktopPath & "test.xlsm"
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    ' Dosyaları aç (Zaten açıksa hata vermez)
    Set wbKaynak = Workbooks.Open(kaynakDosya)
    Set wbHedef = Workbooks.Open(hedefDosya)
    On Error GoTo 0
    
    If wbKaynak Is Nothing Or wbHedef Is Nothing Then
        MsgBox "Dosyalar bulunamadı! Lütfen 'sablon.xlsm' ve 'test.xlsx' dosyalarının masaüstünde olduğundan emin olun.", vbCritical
        Exit Sub
    End If

    ' "Makro" adlı sayfanın kodlarını kopyala
    On Error Resume Next
    With wbKaynak.VBProject.VBComponents(wbKaynak.Sheets("Makro").CodeName).CodeModule
        kaynakKod = .Lines(1, .CountOfLines)
    End With
    On Error GoTo 0
    
    If kaynakKod = "" Then
        MsgBox "Kaynak kod alınamadı! 'Makro' sayfası boş olabilir veya VBA erişim izni kapalı.", vbExclamation
        Exit Sub
    End If
    
    ' "Sayfa1" adlı sayfanın kod bölümüne yapıştır
    With wbHedef.VBProject.VBComponents(wbHedef.Sheets("Sayfa1").CodeName).CodeModule
        .DeleteLines 1, .CountOfLines
        .AddFromString kaynakKod
    End With
    
    ' Önce kaynak (sablon) dosyasını kapat
    wbKaynak.Close SaveChanges:=False
    
    ' Hedef dosyayı yeni isimle (.xlsm) kaydet
    Application.DisplayAlerts = False
    wbHedef.SaveAs Filename:=yeniDosya, FileFormat:=52
    Application.DisplayAlerts = True
    
    ' Eğer eski dosya adı/uzantısı farklıysa (test.xlsx gibi), onu şimdi sil
    ' (SaveAs işleminden sonra wbHedef artık test.xlsm olduğu için eski dosya boşa çıktı)
    If Dir(hedefDosya) <> "" Then
        On Error Resume Next
        Kill hedefDosya
        On Error GoTo 0
    End If

    Application.ScreenUpdating = True
    MsgBox "İşlem başarıyla tamamlandı!" & vbCrLf & _
           "- sablon kapatıldı." & vbCrLf & _
           "- Eski test silindi." & vbCrLf & _
           "- Yeni test.xlsm oluşturuldu.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst