- Katılım
- 24 Temmuz 2019
- Mesajlar
- 413
- Excel Vers. ve Dili
- EXCEL 2010 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 25-12-2023
Herkese iyi çalışmalar diliyorum.
Sayın @halit3 'ün forum içinde sorulan sorulardan birine cevap vermek üzere hazırlamış olduğu çok güzel bir kod var; onu kendi dosyama uyarlamak istiyorum. Bu kod sadece bir sayfayı kopya alarak farklı kaydediyor. Ben ise aynı format ve mantıkla çalışma dosyasını tümüyle farklı kaydetmek istiyorum. farklı kaydederken tüm VBA kodları ve düğmeleri silerek .xls veya .xlsx formatında kaydetmek istiyorum. Yardımcı olur musunuz?
Teşekkürler.
Örnek Dosyam:
Sayın @halit3 'ün forum içinde sorulan sorulardan birine cevap vermek üzere hazırlamış olduğu çok güzel bir kod var; onu kendi dosyama uyarlamak istiyorum. Bu kod sadece bir sayfayı kopya alarak farklı kaydediyor. Ben ise aynı format ve mantıkla çalışma dosyasını tümüyle farklı kaydetmek istiyorum. farklı kaydederken tüm VBA kodları ve düğmeleri silerek .xls veya .xlsx formatında kaydetmek istiyorum. Yardımcı olur musunuz?
Teşekkürler.
Kod:
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub Mahsup_Farklı_Kaydet()
deger = "Maaş_Dosya_Deseni(" & Format(Date, "mmmm") & ")"
Sayfa_Adı = "Sheet1"
'-------------------------------
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
msg = "Lütfen bir klasör seçiniz."
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Lütfen bir klasör seçiniz."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
Klasor = Left(Path, pos - 1)
Else
MsgBox "işlemi iptal ettiniz."
Exit Sub
End If
Dim FileExtStr As String
Dim FileFormatNum As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = Sayfa_Adı Then
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & "\" & deger & ".xls")
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else
sayfa.Copy
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 "Your answer is NO in the security dialog"
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
With wb
If yer = vbYes Then
deger.DrawingObjects.Delete
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 If
.SaveAs Klasor & "\" & deger & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=True
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End If
Next
End Sub
Son düzenleme:
