• DİKKAT

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

Sayfaların kod bölümüne otomatik makro yazılır mı?

T

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,904
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Merhaba Arkadaşlar,
Otomatik oluşturulup, tek dosya haline gelmiş dosyada, eklenen sayfaların her birinin kod bölümüne ayrı ayrı (ilk sayfada belli bir alana AE2:AE6 yazılmış olan makro) yazdırılabilir mi?
Saygılarımla
 
Açıklamanızı tam anlamadım ama; VBA ile sayfa modüllerine kod yazılabilir, silinebilir.... Forumda bununla ilgili örnekler var diye hatırlıyorum.

.
 
Günaydın Haluk Hocam,
Çok aradım ama hiç gözüme çarpmadı. Hatırlayan varsa makbule geçer.
Saygılarımla
 
[TR][TD]
Merhaba Tevfik bey
ek dosyayı denermisiniz?
"Dosya\seçenekler\güven merkezi\güven merkezi ayarları\mako ayarları\vba projesi nesne modeli erişimine güven" işaretli olmalı
Yeni bir dosya oluşturup kodları ekleyerek, dosyanızın yanına kaydedecektir

DosyaUP - Ücretsiz, Hızlı ve Kolay Dosya Paylaşımı - Dosya Upload

DosyaUP, dosya yükleme ve paylaşım platformudur. Tamamen ücretsiz, üyeliğe gerek yok. Hiçbir limit yok. Dosya Yükle. Dosya Upload. Dosya Paylaş
dosyaup.com dosyaup.com
Kod: 
Private Sub CommandButton1_Click()
Dim sat As Long, yeni As Workbook, n As Long
Dim kitap As Object, a As Range
Set yeni = Workbooks.Add
Application.Workbooks(yeni.Name).Activate
For n = 1 To yeni.Sheets.Count
Set kitap = Application.Workbooks(yeni.Name).VBProject.VBComponents(yeni.Sheets(n).Name)
For Each a In ThisWorkbook.ActiveSheet.Range("AE2:AE6")
With kitap.CodeModule
sat = .CountOfLines
sat = sat + 1
.InsertLines sat, a.Value
End With
Next: Next
ChDir ThisWorkbook.Path
yeni.SaveAs Filename:=ThisWorkbook.Path & "\kodlu.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
yeni.Close
End Sub
[/TD][/TR]
 
Merhaba Sayın Plint,
İlginize teşekkür ederim. Ama beklediğim olmadı. Sizin makro da içinde. İsterseniz bir de siz deneyin. Söylediklerinizi aynen uyguladım.
Saygılarımla
Okuma
 

Ekli dosyalar

Ben denediğimde kodları sayfaları ekledi ancak satırlardan birinin sonunda alt tire olduğundan boş bir satır bıraktı
kodlara boş satır için ek yaptım
Kod: 
Sub Kod_Yaz()
Dim sat As Long, yeni As Workbook, n As Long
Dim kitap As Object, a As Range
Set yeni = Workbooks.Add
Application.Workbooks(yeni.Name).Activate
For n = 1 To yeni.Sheets.Count
Set kitap = Application.Workbooks(yeni.Name).VBProject.VBComponents(yeni.Sheets(n).Name)
For Each a In ThisWorkbook.ActiveSheet.Range("AL4:AL10")
With kitap.CodeModule
sat = .CountOfLines
If sat <> 0 Then
If Trim(.Lines(sat, 1)) = vbNullString Then sat = sat - 1
End If
sat = sat + 1
.InsertLines sat, a.Value
End With
Next: Next
ChDir ThisWorkbook.Path
yeni.SaveAs Filename:=ThisWorkbook.Path & "\kodlu.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
'yeni.Close
End Sub
hizliresim.com

yGY1zn.gif - Hızlı Resim

Gif
hizliresim.com hizliresim.com
 
Siz aynı dosya üzerinde eklenen sayfalaramı kodları eklemek istemiştiniz, ben yeni dosya oluşturacaksınız sanıyordum.
 
Merhaba Sayın Plint,
Evet, aslında bir sayfalık bir dosya var. Bu dosyadaki makrolar txt dosyaları excel sayfası yapıyor ve onları birleştirip tek dosya oluşturuyor. Öğrenci durumuna bağlı olarak bazı dosyalar 150, bazı dosyalar 250 sayfa olacak. Eklenen bu sayfalar arasında gidip gelme kolay olsun diye eklenen sayfaların kod bölümüne hem sayfayı düzenli göstersin hem de ilk sayfaya link versin diye ilk sayfadaki AL4:AL10 arasındakileri yazmak istiyorum.
Yardımlarınız için çok teşekkür ederim.
Saygılarımla
 
Son düzenleme:
Rica ederim, saygı bizden
Sayfaları oluşturup, dosya haline getiren kodlarınızı paylaşırsanız, yukarıdaki kodları uyarlamaya çalışırım
 
Sayın Plint Hocam,
BUYRUN ( bu dosyada sadece sizin kodlar eksik )
Saygılarımla
 
Merhaba
"buklasordekiexceldosyalarınıBirleştir" makrosunuza eklenen kodlar; işaretli aralıktaki satırlar.
Kod: 
Sub buklasordekiexceldosyalarınıBirleştir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
yol = ThisWorkbook.Path & "\Excel"
ad = ThisWorkbook.Name
ayrac = Application.PathSeparator
dosya = Dir(yol & ayrac & "*.xlsx")
      Do While dosya <> ""
      If dosya <> ad Then
        Workbooks.Open yol & ayrac & dosya
        Dim sayfa As Worksheet
        For Each sayfa In Workbooks(dosya).Worksheets
        sadi = sayfa.Name
        Workbooks(ad).Activate
        Workbooks(ad).Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sadi
        Workbooks(dosya).Worksheets(sadi).Range("A:AZ").Copy
        Workbooks(ad).Sheets(Sheets.Count).Paste
        '----------------------
   Set kitap = Application.ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName)
For Each a In ThisWorkbook.Sheets("Mebe").Range("AL4:AL10")
With kitap.CodeModule
sat = .CountOfLines
If sat <> 0 Then
If Trim(.Lines(sat, 1)) = vbNullString Then sat = sat - 1
End If
sat = sat + 1
.InsertLines sat, a.Value
End With
Next:
'-------------------------------
        Next
      Workbooks(dosya).Close
      End If
        dosya = Dir()
      Loop
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub
 
Sayın Plint Hocam,
İlginize çok teşekkür ederim. Tam düşündüğüm gibi.
Bu çalışmamın keyfe keder bir noktası kaldı. Başlangıçta Masa üstüne bakarak başlıyor. Halbuki nerede olduğunu biliyor. Bulunduğu klasörden başlasa hiç sıkıntım kalmayacak. Fırsatınız olursa ona da bakar mısınız, lütfen?
Saygılarımla
 
Merhaba
Rica ederim Tevfik bey, saygı bizden
Aşağıdaki makro ikinci satırındaki " &H0" yerine "thisworkbook.path" yazarak denermisiniz?
Kod: 
Sub txt_cevir()

Sayfa_adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Lütfen bir klasör seçiniz", 50, ThisWorkbook.Path)
 
Sayın Plint Hocam,
Çok teşekkür ederim ilginize. Denedim çalışıyor. Ama bir sebepten dolayı bu hata mesajı başladı. Debug a basınca sarı dolgunun geldiği sayfada F5 e bastığınızda da sorunsuz bitiriyor. Ama nedenini anlamadım.
Saygılarımla
 

Ekli dosyalar

  • 2020-01-29_10-39-58.png
    2020-01-29_10-39-58.png
    28.6 KB · Görüntüleme: 5
  • 2020-01-29_10-40-31.png
    2020-01-29_10-40-31.png
    45.8 KB · Görüntüleme: 5
Merhaba
Sayfanın kod adını alamıyor sanırım
Kod adı sayfanın "propeties"teki adı sheets("Mebe").codename = "Sayfa1" gibi
eklenen her sayfanın kod adının alınması gerekiyor
Aşağıda iki kodla değişik şekilde alabiliriz; (birincisi her ihtimale karşı daha uygun olur)
Kod: 
Sub buklasordekiexceldosyalarınıBirleştir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------
 Set dc = CreateObject("Scripting.Dictionary")
 For t = 1 To Application.ThisWorkbook.VBProject.VBComponents.Count
 dc.Add Application.ThisWorkbook.VBProject.VBComponents.Item(t).Name, ""
 Next
 '---------------
yol = ThisWorkbook.Path & "\Excel"
ad = ThisWorkbook.Name
ayrac = Application.PathSeparator
dosya = Dir(yol & ayrac & "*.xlsx")
      Do While dosya <> ""
      If dosya <> ad Then
        Workbooks.Open yol & ayrac & dosya
        Dim sayfa As Worksheet
        For Each sayfa In Workbooks(dosya).Worksheets
        sadi = sayfa.Name
        Workbooks(ad).Activate
        Workbooks(ad).Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sadi
        Workbooks(dosya).Worksheets(sadi).Range("A:AZ").Copy
        Workbooks(ad).Sheets(Sheets.Count).Paste
        Next
      Workbooks(dosya).Close
      End If
        dosya = Dir()
      Loop
   '-------------
  Set dic = CreateObject("Scripting.Dictionary")
   For t = 1 To Application.ThisWorkbook.VBProject.VBComponents.Count
  isim = Application.ThisWorkbook.VBProject.VBComponents.Item(t).Name
 If Not dc.exists(isim) Then dic.Add isim, ""
 Next
 For Each p In dic.keys
 Set kitap = Application.ThisWorkbook.VBProject.VBComponents(p)
For Each a In ThisWorkbook.Sheets("Mebe").Range("AL4:AL10")
With kitap.CodeModule
sat = .CountOfLines
If sat <> 0 Then
If Trim(.Lines(sat, 1)) = vbNullString Then sat = sat - 1
End If
sat = sat + 1
.InsertLines sat, a.Value
End With
Next: Next
  '------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub

Kod: 
Sub buklasordekiexceldosyalarınıBirleştir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
yol = ThisWorkbook.Path & "\Excel"
ad = ThisWorkbook.Name
ayrac = Application.PathSeparator
dosya = Dir(yol & ayrac & "*.xlsx")
      Do While dosya <> ""
      If dosya <> ad Then
        Workbooks.Open yol & ayrac & dosya
        Dim sayfa As Worksheet
        For Each sayfa In Workbooks(dosya).Worksheets
        sadi = sayfa.Name
        Workbooks(ad).Activate
        Workbooks(ad).Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sadi
        Workbooks(dosya).Worksheets(sadi).Range("A:AZ").Copy
        Workbooks(ad).Sheets(Sheets.Count).Paste
        '----------------------
vbad = Application.ThisWorkbook.VBProject.VBComponents.Item(Application.ThisWorkbook.VBProject.VBComponents.Count).Name
   Set kitap = Application.ThisWorkbook.VBProject.VBComponents(vbad)
For Each a In ThisWorkbook.Sheets("Mebe").Range("AL4:AL10")
With kitap.CodeModule
sat = .CountOfLines
If sat <> 0 Then
If Trim(.Lines(sat, 1)) = vbNullString Then sat = sat - 1
End If
sat = sat + 1
.InsertLines sat, a.Value
End With
Next:
'-------------------------------
        Next
      Workbooks(dosya).Close
      End If
        dosya = Dir()
      Loop
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub
 
Sayın Plint Hocam,
İlginize çok teşekkür ederim. Hemen deneyeceğim. Gerekirse ilk sayfaya ekstra isim vermem. Onu Sayfa1 diye bırakırım.
Saygılarımla
 
Sayın Plint Hocam,
Günaydın, 2. veya 3. çalışmada o hata geliyordu. Şimdi 5 defa çalıştırdım hata almadım. Yine olursa sanırım çözüm 17. mesaj. Tekrar teşekkür ederim.
Saygılarımla
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst