Kod Düzenlememe Yardım

[alfaoz]

arkadaşlar merhaba. çalışma kitabındaki sayfaları istediğim klasöre sayfa adıyla yeni bir çalışma kitabı olarak kaydeden bir makrom var. ancak makro kaydederken bazı uyarılar veriyor. bu uyarıları vermemesini ve kullandığım sayfadaki command buttonları da almamasını istiyorum. gerçi command buttonlar çalışmıyor ancak button olarak da bulunmasın istiyorum. bunu nasıl sağlarım.
Kod bu aşağıda da uyarı resimlerini ekledim;
(kusura bakmayın kod kopyalama yöntemini bilmiyorum. Biri bu konuda da bilgilendirirse sevinirim.)
Sub SayfaKaydet()
Application.ScreenUpdating = False
Dim Klasör As Object, Dizin As String, DosyaAdı As Variant
Set Klasör = CreateObject("Shell.Application").BrowseForFoldeR(0, "Lütfen bir Klasör seçin !", 1)

Dim sayfa As Worksheet
For Each sayfa In Worksheets
sayfa.Copy
ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".xls"
ActiveWorkbook.Close False
Next sayfa
Application.ScreenUpdating = True
End Sub

 

[alfaoz]

yardımcı olabilecek var mı?

 

[suleyman242]

(kusura bakmayın kod kopyalama yöntemini bilmiyorum. Biri bu konuda da bilgilendirirse sevinirim.)

Sizin göndermiş olduğunuz kod bu şekilde çıkması için :

Sub SayfaKaydet()
Application.ScreenUpdating = False
 Dim Klasör As Object, Dizin As String, DosyaAdı As Variant
    Set Klasör = CreateObject("Shell.Application").BrowseForFoldeR(0, "Lütfen bir Klasör seçin !", 1)
 
    Dim sayfa As Worksheet
    For Each sayfa In Worksheets
        sayfa.Copy
        ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".xls"
        ActiveWorkbook.Close False
    Next sayfa
    Application.ScreenUpdating = True
End Sub

kodun başına ve sonuna köşeli parantez içerisinde ; baştaki [ CODE ] ,sondaki [ / CODE] ; (köşeli parentez içinde boşluklar olmıyacak ben burda gözükmesi için boşluk verdim) yazarak yada ,mesaj kısmında 2.satır sonunda # yani code ye basarak kod gönderebilirsin.

 

[alfaoz]

Sub SayfaKaydet()
Application.ScreenUpdating = False
Dim Klasör As Object, Dizin As String, DosyaAdı As Variant
Set Klasör = CreateObject("Shell.Application").BrowseForFoldeR( 0, "Lütfen bir Klasör seçin !", 1)

Dim sayfa As Worksheet
For Each sayfa In Worksheets
sayfa.Copy
ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".xls"
ActiveWorkbook.Close False
Next sayfa
Application.ScreenUpdating = True
End Sub

 

[alfaoz]

Sizin göndermiş olduğunuz kod bu şekilde çıkması için :

Sub SayfaKaydet()
Application.ScreenUpdating = False
 Dim Klasör As Object, Dizin As String, DosyaAdı As Variant
    Set Klasör = CreateObject("Shell.Application").BrowseForFoldeR(0, "Lütfen bir Klasör seçin !", 1)
 
    Dim sayfa As Worksheet
    For Each sayfa In Worksheets
        sayfa.Copy
        ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".xls"
        ActiveWorkbook.Close False
    Next sayfa
    Application.ScreenUpdating = True
End Sub

kodun başına ve sonuna köşeli parantez içerisinde ; baştaki [ CODE ] ,sondaki [ / CODE] ; (köşeli parentez içinde boşluklar olmıyacak ben burda gözükmesi için boşluk verdim) yazarak yada ,mesaj kısmında 2.satır sonunda # yani code ye basarak kod gönderebilirsin.

teşekkür ederim. deneme için gönderdim işe yarıyor.

 

[Merhum İdris SERDAR]

.

Excel 2007 için dosyayı kaydederken .xlsm uzantılı olarak kaydetmelisiniz.

Ve koddaki satırı aşağıdaki gibi değiştirin.

ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".[COLOR="Red"]xlsm[/COLOR]"

.

 

[alfaoz]

.

Excel 2007 için dosyayı kaydederken .xlsm uzantılı olarak kaydetmelisiniz.

Ve koddaki satırı aşağıdaki gibi değiştirin.

ActiveWorkbook.SaveAs Klasör.Self.Path & "\" & sayfa.Name & ".[COLOR="Red"]xlsm[/COLOR]"

.

Teşekkürler ancak ben makroların atanmamasını istiyorum. Bu şekilde yazarsam makrolar da aktarılmış olmaz mı?

 

[HALILİBRAHIM]

Hocalar belki alakasız biyerde oldu ama kusura bakmayın konu açmayı unutmuşum benim bir sorum olacak mümkünse hocalar resimlerimi excele kodla getirmeyi buldum evde 2007'de canavar gibi çalışıyor ama iş yerinde 2010 kullanıyoruz ondanmıdır bilmiyorum hocalar "C;\resimler" klasörüne resimleri attım hocalar kodlarla isimler aynı fakat picture ınsert özelliğini alamıyo diye bir hata alıyorum ve bazen hata gittiğinde resimlerdende sadece 11 tane getirebiliyor hocalar birde ben kodumu "c" sütununa yazıp resimin b sütununa gelmesini istiyorum yardım ederseniz çok sevinirim.

kod aşağıdaki gibidir

Sub Düğme3_Tıklat()
Dim a As Integer
Dim son As Integer
Dim ad As String
Dim yol As String

yol = "c:\resimler\"
son = Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To son
ad = yol & Cells(a, 1) & ".jpg"
With ActiveSheet.Pictures.Insert(ad)
.Left = Cells(a, 2).Left
.Top = Cells(a, 2).Top
.ShapeRange.LockAspectRatio = True
.ShapeRange.Height = 50
End With
Rows(a).RowHeight = 50
Next a
MsgBox "İşlem tamamlandı", vbInformation, "T A M A M"
End Sub

 

[vardar07]

Kodları aşağıdakiler ile değiştirip denermisin.

Sub Düğme3_Tıklat()
Dim a As Integer
Dim son As Integer
Dim ad As String
Dim yol As String
yol = "c:\resimler\"
son = Range("[COLOR=red][B]C[/B][/COLOR]" & Rows.Count).End(xlUp).Row ' [COLOR=red]Seçilecek sütun[/COLOR]
For a = 1 To son
    ad = yol & Cells(a, [COLOR=red][B]3[/B][/COLOR]) & ".jpg"   ' [COLOR=red]Seçilecek yol[/COLOR]
    With ActiveSheet.Pictures.Insert(ad)
        .Left = Cells(a, 2).Left   '[COLOR=red]Resmin görüleceği hücre Soldan[/COLOR]
        .Top = Cells(a, 2).Top    '[COLOR=red]Resmin görüleceği hücre Üstten[/COLOR]
        .ShapeRange.LockAspectRatio = True
        .ShapeRange.Height = 50
    End With
    Rows(a).RowHeight = 50
Next a
MsgBox "İşlem tamamlandı", vbInformation, "T A M A M"
End Sub

 

[HALILİBRAHIM]

Hocam çok teşekkür ederim ilginiz için ben zaten yarım yamalak biliyorum hocam ben değiştirdim fakat yine aynı hata hocam printscreen yaptım hocam aldığım hata ekte Allah razı olsun hocam

 

[vardar07]

Hocam çok teşekkür ederim ilginiz için ben zaten yarım yamalak biliyorum hocam ben değiştirdim fakat yine aynı hata hocam printscreen yaptım hocam aldığım hata ekte Allah razı olsun hocam

Merhaba,
Sorun resimler klasörünün bulunduğu yer;
Resimlerin nerede ise kırmızılı yere adresi belirtmen lazım.

 yol = "[B][COLOR=red]c:\resimler\[/COLOR][/B]"

 

[alfaoz]

hocam sorununuzu kendi açtığınız başlıktan çözerseniz sevinirim. çünkü benim sorunum henüz çözülmüş değil ve sizin yazışmalarınız konuya engel oluyor. anlayışınız için teşekkürler.

 

[HALILİBRAHIM]

Vardar hocam şimdilik hallettim çok sağolun Allah razı olsun yaa hocam eline sağlık oldu inş.
Başarılar dilerim...

Alfa hocam ben mağduriyetimden dolayı girdim başlık altına Hakkını helal et seninde işin görülecektir inş. kardeşim bu yukardaki kod'da bir gün işine yarar inşallah hocam kusura bakmayın..

 

[HALILİBRAHIM]

Hocam Özür dileyerek vardar hocama bir şey daha sormam lazım kusura bakmayın lütfen;
Hocam "C" sütununda hücre 1'den başlasam sıkıntı yok fakat 4'cü hücreden kod yazmaya başladığımda "end debug" hatası alıyorum bir çaresi yokmu hocam.. birde kod yanlış oluncada "end ve debug" geliyor bunu nasıl yok edebiliriz hocam..