• DİKKAT

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

Farklı Kaydet. Sütundaki verileri isim olarak ata.

  • Konbuyu başlatan Konbuyu başlatan ahzola
  • Başlangıç tarihi Başlangıç tarihi
A

ahzola

Katılım
17 Ekim 2011
Mesajlar
490
Excel Vers. ve Dili
Excel 2003 - Türkçe
Merhabalar.

Gününüz aydın olsun arkadaşlar.

Forumda arama yaptım lakin benim istediğim kriterlere göre.
Kod tedarik edemedim. Bulduklarımı ise uyarlayamadım.
Yardımlarınızı bekliyorm.

Ekli dosyadaki izahatım.

Bu sayfada "Şehirler Arası" sayfası

Butona bastığmda otomatik olarak
C sütunundaki verilerin sayısı kadar bu kitabı farklı kayıt yapmasını
istiyorm.

Kayıt yapacağı yeri sormayacak.
Kayıt yapacağı yer. Bu kitabın kayıtlı olduğu klasör olacak.
Mesela buradaki listeyi "Deneme" kalsörüne kaydecek.
Çünkü bu kitap "Deneme" kalasörü içinde kayıtlı.

Kayıt yapacağı klasörde mükerrer kayıt durumu falan söz konusu değl
Kod ne kadar sade olursa o kadar iyi olur.

Saygılarımla.
 

Ekli dosyalar

İyi akşamlar

Halen çözüm bulabilmiş değilim.
 
İyi akşamlar.

Aşağıdaki kodu Korhan bey yazmış. Ellerine sağlık.
Kendim uğraştım lakin istediğim şekle getiremedim.

Makrocu arkadaşlar revizyon yapabilirse çok sevinirim.

Makro üzerinde istediğiim revizyon

A1 hücresindeki veri ismiyle farklı kayıt yapıyor.
**Ben ise tek kayıt değil belirlediğim sayıda kopya yapmasını istiyorum.
(A1:A10 aralığındaki veri sayısı kadar)

Dosya yolu manuel yazılıyor
** Dosya yolunu makroyu çalıştırdığım kitaptan almasını istiyorum.
x klasörden y isimli dosyayı çıkartcam ve makroyu çalıştıracağım.
Kopyaladığı yeni dosyaları direkt x klasörün içine atacak

Option Explicit

Kod: Sub Farklı_Kaydet()
If Range("A1") = "" Then
MsgBox "A1 hücresi boş !" & Chr(10) _
& "Lütfen dosya adını giriniz !", vbCritical
Range("A1").Select
Exit Sub
End If

Sheets("Sayfa1").Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\Mustafa\Desktop\" & Range("A1") & ".xls"
ActiveWindow.Close
End Sub
 
Son düzenleme:
ahzola' Alıntı:
İyi akşamlar.

Aşağıdaki kodu Korhan bey yazmış. Ellerine sağlık.
Kendim uğraştım lakin istediğim şekle getiremedim.

Makrocu arkadaşlar revizyon yapabilirse çok sevinirim.

Makro üzerinde istediğiim revizyon

A1 hücresindeki veri ismiyle farklı kayıt yapıyor.
**Ben ise tek kayıt değil belirlediğim sayıda kopya yapmasını istiyorum.
(A1:A10 aralığındaki veri sayısı kadar)

Dosya yolu manuel yazılıyor
** Dosya yolunu makroyu çalıştırdığım kitaptan almasını istiyorum.
x klasörden y isimli dosyayı çıkartcam ve makroyu çalıştıracağım.
Kopyaladığı yeni dosyaları direkt x klasörün içine atacak

Option Explicit

Kod: Sub Farklı_Kaydet()
If Range("A1") = "" Then
MsgBox "A1 hücresi boş !" & Chr(10) _
& "Lütfen dosya adını giriniz !", vbCritical
Range("A1").Select
Exit Sub
End If

Sheets("Sayfa1").Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\Mustafa\Desktop\" & Range("A1") & ".xls"
ActiveWindow.Close
End Sub
Genişletmek için tıkla ...

Merhaba hemşehrim
Tam istediğiniz gibi değil ama belki işnizi görür sanırım
Elimden gelen bu
Masa üstüne deneme adlı klosör açarsanız içine atar değilse klosörü kendi oluşturuyorEkli dosyayı incelermisiniz
 

Ekli dosyalar

Merhabalar
Üstadım çok teşekkür ederim
Elleriniz dert görmesin.

Şimşek hızı ile dosyaları yedekledi lakin ben
bulamıyorum yedekledikleri dosyaları:)

Masaüstünde indirilenler kalasöründen çalıştırdım sizin eki.
Nereye yedek yapmış olabilir acaba?
 
Özür dilerim şimdi buldum.
Deneme klasörü epeyce fazla idi.

Lakin windows bul bulamadı bunu gördüm.

Hemen inceliyorum
 
Alternatif kod:

Kod: 
Sub KAYITYAP()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.Save
Klasor = ThisWorkbook.Path
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare))
For r = 4 To Cells(Rows.Count, "c").End(3).Row
Yedek_Dosya_Adı = Cells(r, "c").Value & uzanti
CreateObject("Scripting.FileSystemObject").CopyFile ThisWorkbook.FullName, Klasor & "\" & Yedek_Dosya_Adı
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "işlem tamam", vbInformation, "U Y A R I "
End Sub
 
Sayın Numan Şamil

Tekrardan teşekkür ederim.
Bu dosya iş yapar.
Ellerinize sağlık.

Ben baktım ama çıkartamadım.
Eğer masaüstüne oluşturduğu dosyayı
D sürücüsüne oluşturur ise bu iş tamamdır.

Saygılarımla.

Edit: Halit Beyin katkısı ile kodumuzu oluşturduk.
Emeğiniz için tekrardan teşekkür ediyorum.
 
Son düzenleme:
Sayın Halit3,

Kod tam manasıyla istedğim vazifeyi yapıyor.

Allah ne muradınız varsa versin.
Üstad ellerinize sağlık.

İnanıyorum ki bu başıktan pekçok kişi istifade edecektir.
Ben günlerce aradım. Karşıma çıkan bütün farklı kayıtlarda
tek hücreden tek dosya kayıt ediliyordu.

İyi forumlar.
 
Son düzenleme:
Buda başka bir alternatif kod:

Kod: 
Sub KAYITYAP2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Klasor = ThisWorkbook.Path
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare))
If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
End If
 
For r = 4 To Cells(Rows.Count, "c").End(3).Row
Sheets(ActiveSheet.Name).Select
Sheets(ActiveSheet.Name).Copy
Sheets(ActiveSheet.Name).Name = Cells(r, "c").Value
 
Yedek_Dosya_Adı = Cells(r, "c").Value &  uzanti
Kayıt_Yeri = Klasor & "\" & Yedek_Dosya_Adı
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Kayıt_Yeri, FileFormat:=FileFormatNum
ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
 
Geç oldu ama güzel oldu.

Alternatif iyidir.
Tekrar tekrar teşekkür ederim
Değerli İnsan.

Saygılarımı kabul edin lütfen.
 
ahzola' Alıntı:
Geç oldu ama güzel oldu.

Alternatif iyidir.
Tekrar tekrar teşekkür ederim
Değerli İnsan.

Saygılarımı kabul edin lütfen.
Genişletmek için tıkla ...

Yukarıdaki mesajlarınızdaki isimleri bilmeden yanlış yazdınız galiba onları düzeltin.

İyi çalışmalar
 
Bu 2 oldu:)

Hayıırdır diyorum kendi kendime.
Hayır olsun inşallah.
 
Merhabalar

Halit Bey

Kod için birkez daha teşekkür ediyorum.
Nokta kadar bir sorun var:)

Farklı kaydet ile yeni oluşturduğumuz dosya isimlernin sonuna "." nokta çıkıyor.
Ben makrodan nokta ibaresi sildim bu kez de dosya formatı değişti.
Dolayısı ile oluşturduğum tüm dosyaların sonu nokta ile bitiyor şuanda.

Bu noktaları kod yardımı ile kaldırma imkanımız olurmu acaba?
 
9 ve 12 nolu mesajdaki kodları düzelttim.
 
Halit Bey

Ben dosyaları çoğaltırken başkaca işlemlerde yapmış idim.
Şöyle tabir edeyim sizin kodu yazmanızdan bu yana
çalışıyorum hemen hemen.

Demem o ki
Kapalı dosya isimlerini değiştirme
şeklinde bir kod yapılabilirmi acaba?

Olmaz ise şayet kısmet deyip tekrar
düzenleyeceğim elbette.

Saygılarımla.
 
Teşekkür ederim.
Halit Bey.

Tekrardan ellerinize sağlık.
İyi günler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst