Farklı kaydet dosya formatı ve sadeleştirme (hızlı çalıştırma)

[YILDIZ YAĞMURU]

Arkadaşlar 2 sorum olacak ...
yardımcı olurmusunuz

1- Aşağıdaki FARKLI KAYDET makrosu sayfadan makroları silerek kaydediyor fakat , EXCEL MAKRO ETKİN ÇALIŞMA KİTABI olarak görünüyor masaüstünde, yani simgesi ve versiyonu excel makro etkin çalışma kitabı olarak kalıyor. bunu EXCEL ÇALIŞMA KİTABI olarak kaydedebilirmiyiz.

2- Aşağıdaki makronun çalışma düzeninde bir değişiklik yapmadan daha hızlı çalışmasını sağlayabilirmiyiz..

İlginiz için çok teşekkür ederim

Sub netfiyatfarklı_kaydet()
ActiveSheet.Unprotect "aaa"
On Error GoTo son
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")
deger = InputBox("dosyanın adı adını değiştirebilirsiniz.", "UYARI!", ActiveSheet.Name) & Format(Now, " dd-mm-yyyy - hh-nn-ss")
deger1 = InputBox("Sayfanın adını değiştirebilirsiniz.", "UYARI!", ActiveSheet.Name)
'dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
'-------------------------------
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
For i = Len(ThisWorkbook.Name) To 1 Step -1
'For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
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 & Uzanti)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else
Sayfa.Copy
'ActiveSheet.Copy
ActiveSheet.Unprotect "aaa"
Range("a1:n175").Select
Selection.Copy
Range("a1:n175").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B1").Select
ActiveCell.FormulaR1C1 = "AKTİVİTE ANLAŞMA FORMU"
Range("B4:M4").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B5:B160").Select
Selection.FormatConditions.Delete
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
For X = [bj65536].End(3).Row To 5 Step -1
If Cells(X, 62) = "X" Then Rows(X).Delete
Next
Range("ab2") = Range("b2")
ActiveSheet.DrawingObjects.Delete
Columns("o:cz").Select
Selection.Delete Shift:=xlToLeft
Columns("h:e").Select
Selection.Delete Shift:=xlToLeft
Rows("5:5").Select
ActiveWindow.FreezePanes = False
Range("E3:F3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Font.Bold = True
Range("E3:F3").Select
ActiveCell.FormulaR1C1 = "NET FİYAT"
Range("d2").Select
ActiveCell.FormulaR1C1 = "ÖNEMLİ"
Range("E3:F3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Application.DisplayFormulaBar = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayWorkbookTabs = True
Range("E2").Validation.Delete
Range("E2").Validation.Add Type:=xlValidateInputOnly, _
AlertStyle:=xlValidAlertStop, Operator:=xlBetween
ActiveWorkbook.Names("data").Delete
Range("B4").AutoFilter
Range("P1").Select
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
With wb
If yer = vbYes Then
ActiveSheet.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
Sheets(ActiveSheet.Name).Name = deger1
.SaveAs Klasor & "\" & deger & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'MsgBox "Kayıt yeri " & Klasor & "\" & deger & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End If
Next
MsgBox "DOSYANIZ SEÇTİĞİNİZ KLASÖRE KAYIT EDİLMİŞTİR", vbInformation
son:
ActiveSheet.Protect "aaa"
End Sub