• DİKKAT

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

Macrolarımı otomatik diğer kitaplara aktarma

A

a_self_lion

Katılım
14 Ocak 2005
Mesajlar
807
Excel Vers. ve Dili
Microsoft Office Professional Plus 2021
Selam Arkadaşlar,

Yapmış olduğum macrolarımı bir kitap içinde xxx.xls her sayfada da kod bölümünde bir takım kodları da mevcup formda mevcut.
Benim bu kodları xxx1.xls xxx2.xls xxx3.xls şeklinde 60 tane kitabım var bunlara bir kodla hepsine bu kodları aktarabilirmiyim içindeki sayfalarda ki kodlar da dahil.
 
Son düzenleme:
a_self_lion' Alıntı:
Selam Arkadaşlar,

Yapmış olduğum macrolarımı bir kitap içinde xxx.xls her sayfada da kod bölümünde bir takım kodları da mevcup formda mevcut.
Benim bu kodları xxx1.xls xxx2.xls xxx3.xls şeklinde 60 tane kitabım var bunlara bir kodla hepsine bu kodları aktarabilirmiyim içindeki sayfalarda ki kodlar da dahil.
Genişletmek için tıkla ...

Aşağıdaki gibi olabilir.

Araçlar/Makro/güvenlik/Güvenilen yayımcılar/Visual basic erişimine güven kutusu işaretli olmalı

Kod: 
Private Sub CommandButton1_Click()
Dim ds, dc, f, s
Dim AA As Workbook
Dim BB As Workbook
Dim CC As String
Dim DestCom As Object
Dim DestMod As Object
With ThisWorkbook
        .VBProject.VBComponents("Module1").Export (ThisWorkbook.Path & "\Module1.bas")
        .VBProject.VBComponents("Module2").Export (ThisWorkbook.Path & "\Module2.bas")
        .VBProject.VBComponents("UserForm1").Export (ThisWorkbook.Path & "\UserForm1.frm")
    End With
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\Y\")
Set dc = f.Files
For Each Dosya In dc
MB = ThisWorkbook.Path & "\Y\" & Dosya.Name
Set ML = New Excel.Application
ML.Workbooks.Open MB
 ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module1.bas")
  ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module2.bas")
   ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Userform1.frm")
For x = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
    Set AA = ThisWorkbook
    Set BB = ML.Workbooks(Dir(MB))
    With AA.VBProject.VBComponents("Sayfa" & x).CodeModule
        CC = .Lines(1, .CountOfLines)
    End With
    Set DestCom = BB.VBProject.VBComponents("Sayfa" & x)
    Set DestMod = DestCom.CodeModule
    With DestMod
        .DeleteLines 1, .CountOfLines
        .AddFromString CC
    End With
        With AA.VBProject.VBComponents("ThisWorkbook").CodeModule
        CC = .Lines(1, .CountOfLines)
    End With
    Set DestCom = BB.VBProject.VBComponents("ThisWorkbook")
    Set DestMod = DestCom.CodeModule
    With DestMod
        .DeleteLines 1, .CountOfLines
        .AddFromString CC
    End With
    Next
ML.Workbooks(Dir(MB)).Close Save = False
ML.Quit
Set ML = Nothing
Next

 Kill ThisWorkbook.Path & "\Module1.bas"
 Kill ThisWorkbook.Path & "\Module2.bas"
   Kill ThisWorkbook.Path & "\Userform1.frm"
   Kill ThisWorkbook.Path & "\Userform1.frx"
End Sub
 

Ekli dosyalar

Çok teşekkür ederim Husgvarna

ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Userform1.frm")
Genişletmek için tıkla ...

Fakat girip çıkınca ikinci çalıştırışımda bu hatayı verdi sanırım userform1.frm var diye veriyor onu nasıl engelleriz varsa eskisi kalsın veya üstüne yenisi kopyalansın gibi. Rica etsem.
 
Bir de burdaki kodlara bir ek yaparak bulunan xxx1.xls xxx2.xls kitaplarıma üç adet sayfa ekleyebilirmiyim. Birisi gizli olacak. --Tanımlar--, --gizliparametre-- ve bu kodumun yazılı olduğu kitabımda bulunan --bilgiler-- sayfa mıda direk olduğu gibi bu xxx1.xls xxx2.xls kitablarıma kopyalamam mümkün mü.
 
Son düzenleme:
Ve bu xxx1.xls ve xxx2.xls sayfalarına kodların görünmemesi şifre de koymak istiyorum.
 
Macrolarımı otomatik diğer kitaplara aktarma ve sayfa kopyalama ve vba şifre koyma

Sayın Husgvarna nin vermiş olduğu kodlar aşağıdadır.

Araçlar/Makro/güvenlik/Güvenilen yayımcılar/Visual basic erişimine güven kutusu işaretli olmalı


Kod: 
Dim ds, dc, f, s
Dim AA As Workbook
Dim BB As Workbook
Dim CC As String
Dim DestCom As Object
Dim DestMod As Object
With ThisWorkbook
        .VBProject.VBComponents("Module1").Export (ThisWorkbook.Path & "\Module1.bas")
        .VBProject.VBComponents("Module2").Export (ThisWorkbook.Path & "\Module2.bas")
        .VBProject.VBComponents("UserForm1").Export (ThisWorkbook.Path & "\UserForm1.frm")
    End With
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\Y\")
Set dc = f.Files
For Each Dosya In dc
MB = ThisWorkbook.Path & "\Y\" & Dosya.Name
Set ML = New Excel.Application
ML.Workbooks.Open MB
 ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module1.bas")
  ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module2.bas")
   ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Userform1.frm")
    
    [B]ML.Workbooks(Dir(MB)).Worksheets.Add
       ML.Workbooks(Dir(MB)).ActiveSheet.Name = "TANIMLAR"
' ASLINDA TANIMLAR DOSYASINI EKLEMEK YERİNE BENDE OLANI O KİTAPLARA KOPYALAMAK İSTİYORUM.   [/B]
 
[B] ML.Workbooks(Dir(MB)).Worksheets.Add
       ML.Workbooks(Dir(MB)).ActiveSheet.Name = "GECIS"[/B]
[B]'GECIS SAYFASI GİZLİ OLARAK AÇILACAK[/B]
 
 
For x = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
    Set AA = ThisWorkbook
    Set BB = ML.Workbooks(Dir(MB))
    With AA.VBProject.VBComponents("Sayfa" & x).CodeModule
        CC = .Lines(1, .CountOfLines)
    End With
    Set DestCom = BB.VBProject.VBComponents("Sayfa" & x)
    Set DestMod = DestCom.CodeModule
    With DestMod
        .DeleteLines 1, .CountOfLines
        .AddFromString CC
    End With
        With AA.VBProject.VBComponents("ThisWorkbook").CodeModule
        CC = .Lines(1, .CountOfLines)
    End With
    Set DestCom = BB.VBProject.VBComponents("ThisWorkbook")
    Set DestMod = DestCom.CodeModule
    With DestMod
        .DeleteLines 1, .CountOfLines
        .AddFromString CC
    End With
    Next
ML.Workbooks(Dir(MB)).Close Save = False
ML.Quit
Set ML = Nothing
Next
 Kill ThisWorkbook.Path & "\Module1.bas"
 Kill ThisWorkbook.Path & "\Module2.bas"
   Kill ThisWorkbook.Path & "\Userform1.frm"
   Kill ThisWorkbook.Path & "\Userform1.frx"

Ben kendime göre bu kodları düzenledim TANIMLAR VE GECIS Diye bir dosya ekletebiliyorum. Benim istediğim burda bir kaç şey daha var

1- TANIMLAR sayfasını Setup olarak kullandığım ve bu kodları diğerlerine aktardığım dosyada var onu olduğu gibi diğer kitaplara kopyalamak istiyorum.
2- GECIS adında eklemiş olduğum sayfamın gizli olmasını istiyorum.
3- Setup olarak kullanığım kitabım daki kodlar vba projectim şifreli doğal olarak kopyalama yapmak istediğinde hata veriyor önce şifreyi kaldırıp kopyaladıktan sonra tekrar şifre koymak istiyorum.
4- Ve diğer kopyaladığı çalışma kitaplarıma da vba project şifresini koymasını istiyorum.
5- Bir kere çalıştırdıktan sonra kodlar hatasız çalışıyor ikinci çalıştırışımda
Kod: 
ML.Workbooks(Dir(MB)).VBProject.VBComponents.Impor t (ThisWorkbook.Path & "\Userform1.frm")
burda hata veriyor. Sanırım bu aynı şeyler olduğu için yapıyor bunun kontrolünü nasıl yapabilirim.

Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.
 
a_self_lion' Alıntı:
S
1- TANIMLAR sayfasını Setup olarak kullandığım ve bu kodları diğerlerine aktardığım dosyada var onu olduğu gibi diğer kitaplara kopyalamak istiyorum.
2- GECIS adında eklemiş olduğum sayfamın gizli olmasını istiyorum.
3- Setup olarak kullanığım kitabım daki kodlar vba projectim şifreli doğal olarak kopyalama yapmak istediğinde hata veriyor önce şifreyi kaldırıp kopyaladıktan sonra tekrar şifre koymak istiyorum.
4- Ve diğer kopyaladığı çalışma kitaplarıma da vba project şifresini koymasını istiyorum.
5- Bir kere çalıştırdıktan sonra kodlar hatasız çalışıyor ikinci çalıştırışımda
Kod: 
ML.Workbooks(Dir(MB)).VBProject.VBComponents.Impor t (ThisWorkbook.Path & "\Userform1.frm")
burda hata veriyor. Sanırım bu aynı şeyler olduğu için yapıyor bunun kontrolünü nasıl yapabilirim.
Genişletmek için tıkla ...
1.
Kod: 
ML.Workbooks(Dir(MB)).ActiveSheet.Name = "TANIMLAR"
Sheets("TANIMLAR").Cells.Copy
ML.Workbooks(Dir(MB)).Sheets("TANIMLAR").Paste
Application.CutCopyMode = xlCopy

2.
Kod: 
 ML.Workbooks(Dir(MB)).Worksheets.Add
ML.Workbooks(Dir(MB)).ActiveSheet.Name = "GECIS"
ML.Workbooks(Dir(MB)).Sheets("GECIS").Visible = False

3.4. Linkte'ki legal çalışmayı uyarlayabilirsiniz.

"www.eggheadcafe.com/software/aspnet/35586196/protection-projet-vba.aspx"

5. "On error resume next"

Kod: 
On error resume next
For Each Dosya In dc

Çalışmanızın küçük bir örneğini eklemeniz; daha iyi olur gibi ...!
 
Son düzenleme:
3.4. Linkte'ki legal çalışmayı uyarlayabilirsiniz.

"www.eggheadcafe.com/software/aspnet/35586196/protection-projet-vba.aspx"
Genişletmek için tıkla ...

Husgvarna

Sevgili Husgvarna size ayrıca çok teşekkür ederim sizin yardımlarınızla kendime özgü bir setup oluşturmayı başardım.

Fakat bu proteck olayını çözemedim.
Benim setup daki vba kodlarım şifreli kodları kopyalaması için diğer xls dosyalarına

1- önce bu şifreyi açması gerekiyor
2- sonra yine bu şifreyi kapatması gerekiyor

3- sonrada bu eklemiş olduğum xxx1.xls xxx2.xls dosyalarıma da vba proteck koymasını istiyorum. Fakat bunu malesef linki incelememe rağmen başaramadım.

Lütfen bu konu ile ilgili yardım edebilirseniz minnettar kalırım.
 
' Şifrele
Sub ProtectVBA()
ProtectVBProject ActiveWorkbook, "OZC"
DoEvents
End Sub

'Şifre aç
Sub UnprotectVBA()
UnprotectVBProject ActiveWorkbook, "OZC"
DoEvents
End Sub


Sub UnprotectVBProject(Wb As Workbook, ByVal Password As String)
Dim vbProj As Object
Set vbProj = Wb.VBProject
'cannot do it if already unlocked!
If vbProj.Protection <> 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = vbProj
' now use lovely SendKeys to quote the project password
SendKeys Password & "~~"
Application.VBE.CommandBars(1).FindControl(ID = 2578, recursive = True).Execute
End Sub


Sub ProtectVBProject(Wb As Workbook, ByVal Password As String)
Dim vbProj As Object
Set vbProj = Wb.VBProject
'cannot do it if already locked!
If vbProj.Protection = 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = vbProj
' now use lovely SendKeys to set the project password
SendKeys "+{TAB}{RIGHT}%V{+}{TAB}" & Password & "{TAB}" & Password & "~"
Application.VBE.CommandBars(1).FindControl(ID = 2578, recursive = True).Execute
Wb.Save
End Sub
Genişletmek için tıkla ...
VBA protect ile ilgili kodları yukarıdaki gibi düzenledim ama projeden bir buttona atayıp
button şifre aç
Call UnprotectVBA

Button şifrele
Call ProtectVBA
invalid pasword hatası alıyorum ve bana pasword girmem için input penceresi çıkıyor nerede hata yapıyor olabilirim.

'http://www.eggheadcafe.com/software/aspnet/35586196/protection-projet-vba.aspx' bu sitedeki kodları uyarlamaya çalıştım.
 
Halit bey tam olarak yapmak istediğim aslında
http://www.excel.web.tr/f48/macrolarymy-otomatik-dioer-kitaplara-aktarma-t99097.html bu linkteki konuyla alakalı olarak
On Error Resume Next
'For Each Dosya In dc


Dim ds, dc, f, s
Dim AA As Workbook
Dim BB As Workbook
Dim CC As String
Dim DestCom As Object
Dim DestMod As Object
With ThisWorkbook
.VBProject.VBComponents("Module1").Export (ThisWorkbook.Path & "\Module1.bas")
'.VBProject.VBComponents("Module2").Export (ThisWorkbook.Path & "\Module2.bas")
.VBProject.VBComponents("UserForm1").Export (ThisWorkbook.Path & "\UserForm1.frm")
.VBProject.VBComponents("UserForm3").Export (ThisWorkbook.Path & "\UserForm3.frm")
End With
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\DENETIM\")
Set dc = f.Files
For Each Dosya In dc
MB = ThisWorkbook.Path & "\DENETIM\" & Dosya.Name
Set ML = New Excel.Application
ML.Workbooks.Open MB
ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module1.bas")
'ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Module2.bas")
ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Userform1.frm")
ML.Workbooks(Dir(MB)).VBProject.VBComponents.Import (ThisWorkbook.Path & "\Userform3.frm")

'burada TANIMLAR Sayfası kopyalanıyor

ML.Workbooks(Dir(MB)).ActiveSheet.Name = "TANIMLAR"
Sheets("TANIMLAR").Cells.Copy
ML.Workbooks(Dir(MB)).Sheets("TANIMLAR").Paste
Application.CutCopyMode = xlCopy
'Burada GECIS diye bir sayfa oluşturuyoruz hedefteki xls dosyasına
ML.Workbooks(Dir(MB)).Worksheets.Add
ML.Workbooks(Dir(MB)).ActiveSheet.Name = "GECIS"
ML.Workbooks(Dir(MB)).Sheets("GECIS").Visible = False
' tamda burada hala bu dosya aktif ken yani diğer xls kitabına geçmeden
Birde burada vba kodlarına yani kopyalamış olduğum hedefteki kitaba vba kodlarına şifre koymak istiyorum burada onu nasıl yapabilirim.


For x = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
Set AA = ThisWorkbook
Set BB = ML.Workbooks(Dir(MB))
With AA.VBProject.VBComponents("Sayfa" & x).CodeModule
CC = .Lines(1, .CountOfLines)
End With
Set DestCom = BB.VBProject.VBComponents("Sayfa" & x)
Set DestMod = DestCom.CodeModule
With DestMod
.DeleteLines 1, .CountOfLines
.AddFromString CC
End With
With AA.VBProject.VBComponents("ThisWorkbook").CodeModule
CC = .Lines(1, .CountOfLines)
End With
Set DestCom = BB.VBProject.VBComponents("ThisWorkbook")
Set DestMod = DestCom.CodeModule
With DestMod
.DeleteLines 1, .CountOfLines
.AddFromString CC
End With
Next
ML.Workbooks(Dir(MB)).Close Save = False
ML.Quit
Set ML = Nothing
Next
Kill ThisWorkbook.Path & "\Module1.bas"
'Kill ThisWorkbook.Path & "\Module2.bas"
Kill ThisWorkbook.Path & "\Userform1.frm"
Kill ThisWorkbook.Path & "\Userform1.frx"

Kill ThisWorkbook.Path & "\Userform3.frm"
Kill ThisWorkbook.Path & "\Userform3.frx"
Call CommandButton3_Click
End Sub
Private Sub CommandButton2_Click()
Dim wb As Workbook
Dim Password As String
Set wb = ActiveWorkbook
Password = "10"
Call SetVBProjectPassword(wb, Password)
End Sub
Genişletmek için tıkla ...

Yukarıdaki kodlarla işimi yapıyorum şimdi sadece yapmak istediğim hedefimdeki xls dosyasınada vba kodlarımı gönderdim ya onlarada şifre koymak istiyorum. tamda burada.

Kod: 
'burada TANIMLAR Sayfası kopyalanıyor
 
ML.Workbooks(Dir(MB)).ActiveSheet.Name = "TANIMLAR"
Sheets("TANIMLAR").Cells.Copy
ML.Workbooks(Dir(MB)).Sheets("TANIMLAR").Paste
Application.CutCopyMode = xlCopy
'Burada GECIS diye bir sayfa oluşturuyoruz hedefteki xls dosyasına 
ML.Workbooks(Dir(MB)).Worksheets.Add
ML.Workbooks(Dir(MB)).ActiveSheet.Name = "GECIS"
ML.Workbooks(Dir(MB)).Sheets("GECIS").Visible = False
' tamda burada hala bu dosya aktif ken yani diğer xls kitabına geçmeden
Birde burada vba kodlarına yani kopyalamış olduğum hedefteki kitaba vba kodlarına şifre koymak istiyorum burada onu nasıl yapabilirim.
 
Bunu kodu kendinize uyarlayınız.

Kod: 
Const BreakIt As String = "%{F11}%TE+{TAB}{RIGHT}%V{+}{TAB}"
Dim deg As String
Private Sub CommandButton1_Click()
Dim Dosya
Dim wb As Workbook
ad = Application.GetOpenFilename
If ad = False Then
MsgBox "Kaynak Dosyayı seçmediniz"
Exit Sub
End If
Application.ScreenUpdating = False
Dosya = ad
Set wb = Workbooks.Open(Dosya, Password:="", WriteResPassword:="")
If ActiveWorkbook.VBProject.Protection = 0 Then
son5 = 1
Else
son5 = 0
End If
UnprotectVBProject Workbooks(Dir(Dosya)), ""   ' "şifreyi yaz" ' sifre yerine vba projesinin şifresi girilmeli
If son5 = 1 Then
siftekoy_Click
End If
ActiveWorkbook.Save
Range("A1").Select
Dosya = Dir
wb.Close False
Application.Visible = True
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
Private Sub siftekoy_Click()
deg = InputBox("şifreyi yazınız.", "şifre", "10") 'madül paraloso kapanış
Dim wb As Workbook
Dim Password As String
Set wb = ActiveWorkbook
Password = deg
Call SetVBProjectPassword(wb, Password)
End Sub
Sub SetVBProjectPassword(wb As Workbook, ByVal Password As String)
Dim VBP
Dim OpenWin
Dim i As Integer
Set VBP = wb.VBProject
Application.ScreenUpdating = False
For Each OpenWin In VBP.VBE.Windows
If InStr(OpenWin.Caption, "(") > 0 Then OpenWin.Close
Next OpenWin
wb.Activate
SendKeys BreakIt & Password & "{tab}" & Password & "~" & "%{F11}~", True
wb.Activate
SendKeys "%{F11}", True
Application.ScreenUpdating = True
End Sub
 
halit bey elinize sağlık ben aşağıdaki şekilde yaptım fakat yine kapalı olan hedefteki xls dosyasını şifreleyemedim.
Sanırım mantığını kuramadım.
ml.Workbooks(Dir(mb)).Active burası yukarıdaki kodlarımda da ne ifade ettiğini zaten biliyorsunuz hedefteki xls dosyasını ifade ediyor. Tam bu ifade ettiği yerde o dosya içine sayfa ekleyebiiyorum. Kopyalama yapabiiryorm. İşte birde vba şifresi koymak istiyorum. Rica etsem bir el atsanız.

ml.Workbooks(Dir(mb)).Active
SifrekoyAc_1_Click
Genişletmek için tıkla ...
 
a_self_lion' Alıntı:
halit bey elinize sağlık ben aşağıdaki şekilde yaptım fakat yine kapalı olan hedefteki xls dosyasını şifreleyemedim.
Sanırım mantığını kuramadım.
ml.Workbooks(Dir(mb)).Active burası yukarıdaki kodlarımda da ne ifade ettiğini zaten biliyorsunuz hedefteki xls dosyasını ifade ediyor. Tam bu ifade ettiği yerde o dosya içine sayfa ekleyebiiyorum. Kopyalama yapabiiryorm. İşte birde vba şifresi koymak istiyorum. Rica etsem bir el atsanız.
Genişletmek için tıkla ...

Bu işlemler baya karışık işler mevcut çalışan kodlarınızla beraber örnek bir dosya ekleyiniz.
 
DENETIM altına koymuş olduğum xxx1.xls xxx2.xls
şeklindeki dosyalarıma
1- setup da bulunan TANIMLAR SAYFASINI KOPYALAMAK
2- VE BİRDE OZCANGECIS diye bir sayfa eklemek ve gizli yapmak
3- vba kodlarımı userformlarımı modüllerimi kopyalamak
4- vba şifresi koymak
burada
1- tamam
2- tamam
3- tamam
4- hedef xxx1.xls ve xxx2.xls gibi DENETIM klasörü altındaki kitaplarıma vba şifresi de koymak
dosyamı ekliyorum sayın halit bey Kapak kısmından başlıyoruz
 

Ekli dosyalar

Dosyana şifre koymuşsun

örnek dosya ekliyorum ona bir bakınız.
 
Şifresi 10 du sizin örnekten yola çıktığımdan söyleme gereği duymamıştım. Özür dilerim. Sizinkinde de 10 du. :) Bu örneklede yapamadım dediğiniz gibi biraz karışık olduğundan zorluyor beni benim dosyadan bir bakarmısınız rica etsem.
 
ttttt.rar daki excel deki kodlarla bir excel kitabı seçiyorum şire koy diye inpup çıkıyor 10 yazıyorum işlem tamam diyor.
Fakat gidip o seçtiğim o dosyaya bakıyorum şifre koymamış.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst