- Katılım
- 9 Ocak 2011
- Mesajlar
- 88
- Excel Vers. ve Dili
- 2007 türkçe
üstadlarım ben aşağıdaki farklı kaydet macrosunu kendime göre uyarladım yapandan allah razı olsun sorunsuz çalışıyor. fakat benim pc de çalışıyor.
bu dosyayı tüm şirket içinde kullanmamız gerekiyor. bu yüzden dosya kayıt yolunun otomatik algılanmasını istiyorum. yani bu dosyayı herhangi bir bilgisayara yolladığım zaman o kişi bu dosyayı masaüstüne kaydedecek ve bu dosyada farklı kaydet butonunu kullandığı zaman macro dosya yolunu otomatik algılayıp masaüstüne kaydedecek.
yardımcı olursanız çok sevineceğim.. şimdiden teşekkürler.
Sub FARKLIKAYDETSUBELİ()
'
' FARKLIKAYDETSUBELİ Makro
'
'
Sheets("PROF").Select
Range("C1:Z172").Select
Selection.Copy
Sheets("PROF-MAİL").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("C4").Select
Klasor = Worksheets("GİRİS").Range("B4").Value
Dosya_Adi = Worksheets("PROF").Range("AW2").Value
Sayfa_Adı = "PROF-MAİL"
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim wb As Workbook
Set wb = ActiveWorkbook
With wb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'MsgBox "HATA VAR"
FileExtStr = Right(Sourcewb.Name, 5)
FileFormatNum = 52
'Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & Dosya_Adi & FileExtStr)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = Sayfa_Adı Then
sayfa.Copy
ActiveWorkbook.SaveAs Klasor & Dosya_Adi & FileExtStr, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
MsgBox Klasor & Dosya_Adi & FileExtStr & " Dosya kayıt edildi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End If
End Sub
bu dosyayı tüm şirket içinde kullanmamız gerekiyor. bu yüzden dosya kayıt yolunun otomatik algılanmasını istiyorum. yani bu dosyayı herhangi bir bilgisayara yolladığım zaman o kişi bu dosyayı masaüstüne kaydedecek ve bu dosyada farklı kaydet butonunu kullandığı zaman macro dosya yolunu otomatik algılayıp masaüstüne kaydedecek.
yardımcı olursanız çok sevineceğim.. şimdiden teşekkürler.
Sub FARKLIKAYDETSUBELİ()
'
' FARKLIKAYDETSUBELİ Makro
'
'
Sheets("PROF").Select
Range("C1:Z172").Select
Selection.Copy
Sheets("PROF-MAİL").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("C4").Select
Klasor = Worksheets("GİRİS").Range("B4").Value
Dosya_Adi = Worksheets("PROF").Range("AW2").Value
Sayfa_Adı = "PROF-MAİL"
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim wb As Workbook
Set wb = ActiveWorkbook
With wb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'MsgBox "HATA VAR"
FileExtStr = Right(Sourcewb.Name, 5)
FileFormatNum = 52
'Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & Dosya_Adi & FileExtStr)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = Sayfa_Adı Then
sayfa.Copy
ActiveWorkbook.SaveAs Klasor & Dosya_Adi & FileExtStr, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
MsgBox Klasor & Dosya_Adi & FileExtStr & " Dosya kayıt edildi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End If
End Sub
