Farkli kaydet makrosu

[exclusiveman]

sevgili arkadaslar

farkli kaydetmeyle ilgili sorunum var. arama bolumunden bir cok sonuc elde ettim ancak isin icinden cikamadim yardimci olursaniz sevinirim.

sevgiler

not: ekteki dosyada aciklama mevcuttur.

 

[halit3]

bu kodu denermisiniz örnek olarak D1 hücresine klasör adını yazınız.

Sub kayitet()
müsteri = Cells(7, "f").Value
deger = Cells(5, "f").Value '& ".xls"
Sayfa_adi = "FATURA GIRISI"
On Error Resume Next
Kaynak = "D:\Factures\" & müsteri
If Dir("D:\Factures") = "" Then MkDir ("D:\Factures")
If Dir(Kaynak) = "" Then MkDir (Kaynak)
On Error Resume Next
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Kaynak & "\" & deger & ".xls")
If a = True Then
MsgBox "Bu isimde bir dosya var"
Exit Sub
Else
End If
Dim sayfa As Worksheet
For Each sayfa In Worksheets
MsgBox Worksheets
If sayfa.Name = Sayfa_adi Then
sayfa.Copy
vbprojectsil
'ActiveSheet.DrawingObjects.Delete
nesne_sil
ActiveWorkbook.SaveAs Kaynak & "\" & deger & ".xls"
ActiveWorkbook.Close False
Exit Sub
End If
Next sayfa
End Sub
Sub vbprojectsil()
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
End Sub
Sub nesne_sil()
Dim Picture As Object, Bak As String, Uzunluk As Byte
Bak = "AutoShape"
Uzunluk = Len(Bak)
For Each Picture In ActiveSheet.Shapes
If Mid(Picture.Name, 1, Uzunluk) = Bak Then
Picture.Delete
End If
Next Picture
End Sub

 

[exclusiveman]

hocam tek kelime ile super olmus ellerinize saglik. yanliz benim logo da gitmis kaydettikten sonra her seferinde elle tekrar mi eklemeliyim?
Ayrica ekte ufak bir ekleme icin ornek sunuyorum inceleyip yardimci olabilirseniz minettar olurum.
sevgilerimle

 

[halit3]

2 nolu mesajdaki kodu yeniden düzeltim

logo işin tamam diğer sorunu anlayamadım

 

[exclusiveman]

Hocam sanirim benim hatam yeterli aciklama yapamadim sorum icin.kisaca soylemek gerekirse, müsteri = Cells(7, "f").Value hucresine gore diger sayfalara kayit yapiyoruz benim ek olarak sizden istedigim kontrolu saglamam acisindan fatura girisi yaptigimiz xls dosyasinda sayfa2,sayfa3... Sheetlerine de kayit tusuna bastigimda musteri ismine gore sayfa acip alt alta kayit yapmasi. Yukaridaki 2.ornegimle beraber yazdigimi okursaniz aciklayici olacagina inaniyorum. Ornekte sayfalari olusturdum. Ilginiz ve yardimlariniz icin tekrar tesekkur ederim

 

[halit3]

Client bilgileri - fatura girisi … gibi asagida goreceginiz uzere bolumler mevcut. Bunlarin hemen yanina her musteriye ait bolumler acsak ve borc alacak durumunu takip etsek nasil olur? yani yapilan faturalarin bir kopyasi da burada olacak? makroya ekleyebilir miyiz? ornegi incelerseniz memnun olurum.


SOPAREC
OBATEM
FATURA GIRISI
CLIENT BILGILERI

mevcut sayfaların bu

müşteri ismine göre sayfalar nereye açılacak burada sayfa2 ve sayfa3 yok

şimdi yazından birşey anlamadım örneklerle hangi veriyi nereye eklemek istiyorsunuz.

benim yazdığım kod sadece farklı kayıt et koduydu

 

[exclusiveman]

hocam zaten bahsettigim sayfa2 sayfa3... ornekti. yani burada sayfa2 sayfa3 dedigim sey soparec,obatem,xxx,yyy..... gibi musteri isimleri.onlar otomatik kendisi olusacak.ekteki ornegi incelerseniz memnun olurum.

 

[halit3]

hocam zaten bahsettigim sayfa2 sayfa3... ornekti. yani burada sayfa2 sayfa3 dedigim sey soparec,obatem,xxx,yyy..... gibi musteri isimleri.onlar otomatik kendisi olusacak.ekteki ornegi incelerseniz memnun olurum.

örneklerinizi varsayılan dosyanız üzerinde var olan sayfa ve hücredeki değerlerle açıklayıcı olsaydınız bu kadar yazışmaya gerek olmazdı anlamaya çalışmak için baya zaman harcıyoruz.

ekli dosyaya bir bakınız örneksayfa mevcut bunu silmeyiniz ve adını değiştirmeyiniz. çünkü yeni müşteri için açılacak sayfanın formatıdır.
siz o sayfayı kendinize göre düzenlersiniz.

 

[exclusiveman]

sizi oyaladigim icin lutfen kusuruma bakmayin. acemiligime verin lutfen.
son birsey; kaydet butonuna bastigimizda mukerrer kayit yapmasini engelleyebilir miyiz? farkli kaydet makronuzda bu engelleniyor ancak aktar makronuzda kac kere kaydete basarsaniz basin ayni fatura numarasinda alt alta eklemeye devam ediyor. ayni fatura numarasi ile 2. kayit yapilmasini bir msgbox ile "ayni fatura nosu ile yeni kayit yapacak misiniz?"gibi bir sorguya baglayabilir miyiz? hersey icin tekrar tesekkur ederim.

 

[halit3]

bu kodu denermisiniz.

Sub aktar()
yer = Sheets("FATURA GIRISI").Cells(7, 6).Value
deg1 = 0
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name = yer Then
deg1 = 1
End If
Next
If deg1 <> 1 Then
Sheets("örneksayfa").Select
Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
Sheets(ActiveSheet.Name).Select
Sheets(ActiveSheet.Name).Name = yer
Sheets(ActiveSheet.Name).Move After:=Sheets(ActiveWorkbook.Sheets.Count)
Sheets("FATURA GIRISI").Select
End If
If WorksheetFunction.CountIf(Sheets(yer).Range("B:B"), Sheets("FATURA GIRISI").Cells(5, 6).Value) Then
a = MsgBox("bu kayıt mevcut genede eklemek isiyormusunuz. ", vbYesNo + vbInformation, " uyarı")
If a = vbNo Then
Exit Sub
End If
End If
sat = Worksheets(yer).[a65536].End(3).Row + 1
Sheets(yer).Cells(sat, 1).Value = Sheets("FATURA GIRISI").Cells(5, 7).Value
Sheets(yer).Cells(sat, 2).Value = Sheets("FATURA GIRISI").Cells(5, 6).Value
Sheets(yer).Cells(sat, 3).Value = Sheets("FATURA GIRISI").Cells(16, 2).Value
Sheets(yer).Cells(sat, 4).Value = Sheets("FATURA GIRISI").Cells(44, 8).Value
Sheets(yer).Cells(sat, 5).Value = Sheets("FATURA GIRISI").Cells(46, 8).Value
MsgBox " Düzenleme Tamanlanmıştır..."
End Sub

 

[exclusiveman]

cok tesekkur ederim yardimlarin icin. hersey gonlunce olsun.