Excel Sayfalarını Klasör İçerisine Kopyalamak

[ormann]

İyi günler ;
Ekteki harcırah sayfasında ki ComboBox.1'den 8 adet sayfadan her hangi bir sayfayı seçip (örneğin:Harcırah sayfasını) aktar butonuna bastığım zaman masa üstünde harcırah isimli bir klasör oluşturup;hangi sayfayı aktardıysam excel sayfasını o isimle bu klasörün içerisine kayıt yaptırabilirmiyiz?

 

[ormann]

Arkadaşlar yardımcı olabilirmisiniz?

 

[Excelmy]

Sayın ormann

Sayfadaki AKTAR butonuna aşağıdaki kodları ekleyiniz.

Private Sub CommandButton5_Click()
Dim KtPAd, SyFAd, KyNK As String
CommandButton3_Click
KtPAd = ActiveWorkbook.ActiveSheet.Name
SyFAd = ActiveSheet.Name
On Error Resume Next
KyNK = "" & CreateObject("Wscript.Shell").Specialfolders("Desktop") & "\HARCIRAH"
If Dir(KyNK) = "" Then MkDir (KyNK)
On Error Resume Next
Dim sayfa As Worksheet
For Each sayfa In Worksheets
MsgBox Worksheets
If sayfa.Name = SyFAd Then
sayfa.Copy
ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs KyNK & "\" & KtPAd & ".xls", FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
ActiveWorkbook.Close False
End If
Next sayfa
Sheets("VERİ GİRİŞİ").Select
End Sub

 

[ormann]

Excelmy iyi akşamlar vermiş olduğunuz kodu aynen dediğiniz gibi yaptım.Masa üstüne harcırah isimli bir klasör açıyor.Fakat Klasörün içi boş gözüküyor.Yani Combobox'tan seçmiş olduğum sayfa Harcırah klasörünün içerisinde gözükmüyor.Sizden ricam eğer olursa koda ilave olarak kaydedilen sayfa formülleri ile değilde değerleri ile kayıt yapılabilir mi?

 

[halit3]

İyi günler ;
Ekteki harcırah sayfasında ki ComboBox.1'den 8 adet sayfadan her hangi bir sayfayı seçip (örneğin:Harcırah sayfasını) aktar butonuna bastığım zaman masa üstünde harcırah isimli bir klasör oluşturup;hangi sayfayı aktardıysam excel sayfasını o isimle bu klasörün içerisine kayıt yaptırabilirmiyiz?

Merhaba
Sayın ormann

990 mesajınız var makroları öğrenmeye gayret edin

kod:

Sub çalışmakitabıyap()

Dim fL As Object
Dim X As Range
Set fL = CreateObject("Scripting.FileSystemObject")

Kaynak = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\harcırah"

If fL.FolderExists(Kaynak) = False Then
MkDir Kaynak
End If


Uzanti = "." & fL.GetExtensionName(ThisWorkbook.FullName)
dosya_sayisi = fL.GetFolder(Kaynak).Files.Count
Sayfa_adi = Sheets("VERİ GİRİŞİ").ComboBox1.Text

Sheets(Sayfa_adi).Copy
Worksheets(ActiveSheet.Name).Unprotect 1978
ActiveSheet.DrawingObjects.Delete

sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

For Each X In Range("A1:" & Cells(sat, sut).Address)
X.Value = X.Value
Next X

For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next

ActiveWorkbook.SaveAs Kaynak & "\" & Sayfa_adi & dosya_sayisi & Uzanti
ActiveWorkbook.Close False

MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub

 

[ormann]

Halit bey aşağıdaki makroda hata veriyor
For Each component In ActiveWorkbook.VBProject.VBComponents

 

[halit3]

Halit bey aşağıdaki makroda hata veriyor
For Each component In ActiveWorkbook.VBProject.VBComponents

Profilinizde excelin hangi versiyonunu kullandığınız yazmıyor.

 

[ormann]

Halit bey 2003 versiyonunu kullanıyorum.

 

[halit3]

Halit bey 2003 versiyonunu kullanıyorum.

Bu konu yerine Profilinize yazmanız daha iyi olurdu size cevap verirken profilinize bakıyorum ona göre cevap veriyorım.

 

[ormann]

Halit bey kodları 2003 versiyonuna göre rica etsem düzenleyebilirmisiniz ?

 

[halit3]

Halit bey kodları 2003 versiyonuna göre rica etsem düzenleyebilirmisiniz ?

Kod:

Sub çalışmakitabıyap()

Dim fL As Object
Dim X As Range
Set fL = CreateObject("Scripting.FileSystemObject")

Kaynak = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\harcırah"

If fL.FolderExists(Kaynak) = False Then
MkDir Kaynak
End If

Uzanti = "." & fL.GetExtensionName(ThisWorkbook.FullName)
dosya_sayisi = fL.GetFolder(Kaynak).Files.Count
Sayfa_adi = Sheets("VERİ GİRİŞİ").ComboBox1.Text

Sheets(Sayfa_adi).Copy
Worksheets(ActiveSheet.Name).Unprotect 1978
ActiveSheet.DrawingObjects.Delete

sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

For Each X In Range("A1:" & Cells(sat, sut).Address)
X.Value = X.Value
Next X

Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(Worksheets(1).CodeName).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines

ActiveWorkbook.SaveAs Kaynak & "\" & Sayfa_adi & dosya_sayisi & Uzanti
ActiveWorkbook.Close False

MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub

 

[ormann]

Halit bey şimdi de şu makroda hata gösteriyor

Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(Worksheets(1).CodeName).CodeModule

 

[halit3]

Halit bey şimdi de şu makroda hata gösteriyor

Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(Worksheets(1).CodeName).CodeModule

1 nolu mesajdaki dosyada deniyorum bende çalışıyor.

 

[ormann]

Halit bey o kadar denememe rağmen yine hata veriyor.
"visual basic projesine programlı olarak erişim güvenli değil uyarıs veriyor"

 

[halit3]

Halit bey o kadar denememe rağmen yine hata veriyor.
"visual basic projesine programlı olarak erişim güvenli değil uyarıs veriyor"

Sanki geçmiştede bu durumla ilgili sizinle baya mesajlaşmıştık. gibi geldi bana

Sizin sorularınıza cevap vermekten kaçınmıyorum çünkü her seferinde bizim bilmediğimiz sorunlarınızla karşılaşıyoruz.

Bu mesajınızı daha önce yazmış olsaydınız bu kadar yazışma yapmamış olacaktık.

Araçlar/makro/güvenlik tıkla

güvenilen yayıncıları tıkla
Visual Basic Procet erişimine güven tikini işaretle

 

[ormann]

Halit bey sizi bayağı bir uğraştırdığım için özür diliyorum.Şimdi oldu.Çok teşekkür ederim.