• DİKKAT

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

makro ile klasör açma

D

djoguzz

Katılım
2 Mart 2011
Mesajlar
120
Excel Vers. ve Dili
İşyerinnde Excel 2003
Evde Excel 2010
Arkadaşlar ben çok yoğun bi şirkette ön muhasebe elemanıyım bu yüzden forum içerisinde arama yapmaya vaktim olmadığı için konu açmak zorunda kaldım. Daha önceden varsa konu kusura bakmayın lütfen.

Şimdi sorun şu

Ben her müşteri için proforma fatura ve yanında 4 evrak daha doldurup gönderiyorum.

excel tablomda "(satışlar,giderler,)proforma,özkaynak,krd.değ.,kefil,tarm.krd" olmak üzere 5 sayfa var.

ben Proforma sayfasına bir buton ekleyip ona tıkladığımda parantez içine aldığım sayfalar değilde geri kalan sayfaları müşterinin ismine göre kaydetsin istiyorum. müşteri ismide proforma!A2 de mevcut ordan klasörün ismini alsın ve 5 sayfayı bir excel dosyası olarak kaydetsin istiyorum.

Karışık oldu sanırım biraz ama inşallah derdime çare bulabilirim :) Teşekkürler şimdiden herkese..
 
dosya eklerseniz yardımda alabilirsiniz
bu şekilde bir şey görmeden zor
 
ekte bir örnek var arkadaşlar inşallah çözebiliriz şu işi :(
 

Ekli dosyalar

djoguzz' Alıntı:
ekte bir örnek var arkadaşlar inşallah çözebiliriz şu işi :(
Genişletmek için tıkla ...

seferlik benden olsun
bu kodu bir module atıyarak deneyiniz
Kod: 
Sub farklı()
Set WSHShell = CreateObject("wscript.Shell")
strDesktopPath = WSHShell.specialfolders.Item("Desktop")
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
ds.CreateFolder strDesktopPath & "\" & Range("C11")
ActiveWorkbook.SaveAs Filename:=strDesktopPath & "\" & Range("C11") & "\" & Range("C11") & " .xls"
Application.DisplayAlerts = False
Worksheets("satışlar").Delete
Worksheets("giderler").Delete
ThisWorkbook.Save
End Sub
 
djoguzz' Alıntı:
ekte bir örnek var arkadaşlar inşallah çözebiliriz şu işi :(
Genişletmek için tıkla ...

Merhaba;

Kod: 
Option Explicit
Sub FARKLI_KAYDET()
Dim Dosya_Yolu,Dosya_Adı
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PROFORMA").Range("C11")
Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Dosya yolunu seçin !", &H500)
   If Not Dosya_Yolu Is Nothing Then
        Dosya_Yolu = Dosya_Yolu.self.Path
        If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("satışlar", "giderler", "özkaynak", "krd değ.", "trm kredi", "kefil")).Copy
ActiveWorkbook.SaveAs Filename:="" & Dosya_Yolu & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub
Alternatif olsun.
 
usubaykan' Alıntı:
Merhaba;

Kod: 
Option Explicit
Sub FARKLI_KAYDET()
Dim Dosya_Yolu,Dosya_Adı
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PROFORMA").Range("C11")
Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Dosya yolunu seçin !", &H500)
   If Not Dosya_Yolu Is Nothing Then
        Dosya_Yolu = Dosya_Yolu.self.Path
        If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("satışlar", "giderler", "özkaynak", "krd değ.", "trm kredi", "kefil")).Copy
ActiveWorkbook.SaveAs Filename:="" & Dosya_Yolu & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub
Alternatif olsun.
Genişletmek için tıkla ...





herkese teşekkürler iki kodda gayet iyi çalışıyor ancak sadece aşağıda verdiğim kodda dosya yolunu C:\Documents and Settings\Administrator\Desktop\OĞUZ\KREDİ EVRAKLARI\ olarak değiştirebilir miyiz. birde bu dizinin içine excel dosyasının ismi ile aynı şekilde klasör açıp o klasörün içine excell dosyasını kaydetecek.


Sub FARKLI_KAYDET()
Dim Dosya_Yolu, Dosya_Adı
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PRO.HZ").Range("C7")
Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder( 0, "Dosya yolunu seçin !", &H500)
If Not Dosya_Yolu Is Nothing Then
Dosya_Yolu = Dosya_Yolu.self.Path
If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("PRO", "Kredi Değ.", "ÖZKAYNAK", "TRM.KRD", "KEFİL")).Copy
ActiveWorkbook.SaveAs Filename:="" & Dosya_Yolu & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub
 
Son düzenleme:
djoguzz' Alıntı:
herkese teşekkürler iki kodda gayet iyi çalışıyor ancak sadece aşağıda verdiğim kodda dosya yolunu C:\Documents and Settings\Administrator\Desktop\OĞUZ\KREDİ EVRAKLARI\ olarak değiştirebilir miyiz. birde bu dizinin içine excel dosyasının ismi ile aynı şekilde klasör açıp o klasörün içine excell dosyasını kaydetecek.


Sub FARKLI_KAYDET()
Dim Dosya_Yolu, Dosya_Adı
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PRO.HZ").Range("C7")
Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder( 0, "Dosya yolunu seçin !", &H500)
If Not Dosya_Yolu Is Nothing Then
Dosya_Yolu = Dosya_Yolu.self.Path
If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("PRO", "Kredi Değ.", "ÖZKAYNAK", "TRM.KRD", "KEFİL")).Copy
ActiveWorkbook.SaveAs Filename:="" & Dosya_Yolu & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub
Genişletmek için tıkla ...





yokmu bilen birisi :( bu kodda kayıt yolunu kendim seçmem gerekiyor onun yerine belirlediğim bir dizine kendisi otomatik kaydetsin istiyorum yokmu yapabilecek birisi :(
 
Böyle deneyin.
Kod: 
Sub FARKLI_KAYDET()
Dim Dosya_Yolu, Dosya_Adı, ds
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PRO.HZ").Range("C7")
Dosya_Yolu = "C:\Documents and Settings\Administrator\Desktop\OĞUZ\KREDİ EVRAKLARI"
Set ds = CreateObject("Scripting.FileSystemObject")
X = Dosya_Yolu & "\" & Dosya_Adı
a = ds.FolderExists(X)
If a <> True Then
ds.CreateFolder X
End If

If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("PRO", "Kredi Değ.", "ÖZKAYNAK", "TRM.KRD", "KEFİL")).Copy
ActiveWorkbook.SaveAs Filename:="" & X & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
hamitcan' Alıntı:
böyle deneyin.
Kod: 
sub farklı_kaydet()
dim dosya_yolu, dosya_adı, ds
application.screenupdating = false
application.displayalerts = false
set dosya_adı = sheets("pro.hz").range("c7")
dosya_yolu = "c:\documents and settings\administrator\desktop\oğuz\kredi evrakları"
set ds = createobject("scripting.filesystemobject")
x = dosya_yolu & "\" & dosya_adı
a = ds.folderexists(x)
ıf a <> true then
ds.createfolder x
end ıf

ıf len(dosya_yolu) <= 3 then dosya_yolu = replace(dosya_yolu, "\", "")
sheets(array("pro", "kredi değ.", "özkaynak", "trm.krd", "kefil")).copy
activeworkbook.saveas filename:="" & x & "\" & dosya_adı & " .xls", fileformat:=xlnormal, password:="", writerespassword:="", readonlyrecommended:=false
activeworkbook.close
application.screenupdating = true
application.displayalerts = true

end sub
Genişletmek için tıkla ...


çok teşekkürler sorun halloldu tam istediğim gibi kodların arasına da dosya kaydedildi uyarısı ekledim çok güzel oldu :) yardımcı olan herkese çok teşekkürler hamitcan hocama ayrı teşekkürler :)
 
usubaykan' Alıntı:
Merhaba;

Kod: 
Option Explicit
Sub FARKLI_KAYDET()
Dim Dosya_Yolu,Dosya_Adı
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dosya_Adı = Sheets("PROFORMA").Range("C11")
Set Dosya_Yolu = CreateObject("Shell.Application").BrowseForFolder(0, "Dosya yolunu seçin !", &H500)
   If Not Dosya_Yolu Is Nothing Then
        Dosya_Yolu = Dosya_Yolu.self.Path
        If Len(Dosya_Yolu) <= 3 Then Dosya_Yolu = Replace(Dosya_Yolu, "\", "")
Sheets(Array("satışlar", "giderler", "özkaynak", "krd değ.", "trm kredi", "kefil")).Copy
ActiveWorkbook.SaveAs Filename:="" & Dosya_Yolu & "\" & Dosya_Adı & " .xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub
Alternatif olsun.
Genişletmek için tıkla ...


Benimde bir sorum olacak. Benzer bir kopyalama işlemi yaptırmaya çalışıyorum. Ancak:

1-Kopyalarken "farklı kaydet" menüsü çıksın; dosya adını biz yazalım, kayıt klasörünü biz seçelim.
2-Kopyalama yapılırken asıl dosyanın makrolarını ve yine asıl dosyanın sayfa koruma şifrelerini kopyalanmasın. Sayfaların diğer tüm yapısı (satır yüksaklikleri, sütun genişlikleri, birleştirilmiş hücreler, formüller vs.) kopyalansın.

Böyle birşey yaptırılabilir mi?
 
gnorar' Alıntı:
Benimde bir sorum olacak. Benzer bir kopyalama işlemi yaptırmaya çalışıyorum. Ancak:

1-Kopyalarken "farklı kaydet" menüsü çıksın; dosya adını biz yazalım, kayıt klasörünü biz seçelim.
2-Kopyalama yapılırken asıl dosyanın makrolarını ve yine asıl dosyanın sayfa koruma şifrelerini kopyalanmasın. Sayfaların diğer tüm yapısı (satır yüksaklikleri, sütun genişlikleri, birleştirilmiş hücreler, formüller vs.) kopyalansın.

Böyle birşey yaptırılabilir mi?
Genişletmek için tıkla ...


Merhaba;

İlk sayfadaki alternatif olarak verilen kodda zaten kayıt yerini ve dosya ismini siz belirliyorsunuz ama diğer istedikleriniz için inşallah bi arkadaş yardımcı olur.
 
gnorar' Alıntı:
Benimde bir sorum olacak. Benzer bir kopyalama işlemi yaptırmaya çalışıyorum. Ancak:

1-Kopyalarken "farklı kaydet" menüsü çıksın; dosya adını biz yazalım, kayıt klasörünü biz seçelim.
2-Kopyalama yapılırken asıl dosyanın makrolarını ve yine asıl dosyanın sayfa koruma şifrelerini kopyalanmasın. Sayfaların diğer tüm yapısı (satır yüksaklikleri, sütun genişlikleri, birleştirilmiş hücreler, formüller vs.) kopyalansın.

Böyle birşey yaptırılabilir mi?
Genişletmek için tıkla ...

Forumda daha önceden buna benzer sorular çözülmüştü. Aklıma ilk gelen anahtar sözcükler, "farklı kaydet" yada "yedekleme". Bence öncelikle bu şekilde bir arama yapmayı deneyin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst