ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[fenerbahcem]

For i = LBound(SayfaNumaralari) To UBound(SayfaNumaralari)
SayfaNumarasi = Val(SayfaNumaralari(i))
SayfaAdi = ActiveWorkbook.Sheets(SayfaNumarasi).Name
YeniDosyaAdi = YeniKlasor & "\" & SayfaAdi & ".xlsx"
ActiveWorkbook.Sheets(SayfaNumarasi).Copy
ActiveWorkbook.SaveAs Filename:=YeniDosyaAdi, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
Next i

Değerli arkadaşlar ;

Yukardaki makro kodu sayfayı formüllü olarak kayıt etmektedir.
Benim istediğim formüller olmadan sadece değerler olarak kayıt etmesi.
Bu kodu revize ederseniz çok sevinirim.

[düşünceli]

Sub farklıkaydet() 'Aktif Olan Bütün Sayfaları değer olarak kaydeder.
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set Sourcewb = ThisWorkbook
DateString = Format(Now, "dd.mm.yyyy & hh.mm.ss")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName
For Each sh In Sourcewb.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
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
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With
End If
GoToNextSheet:
Next sh
MsgBox "Kaydedilen Yeni Dosyalarınızı Bu Klasörde Bulabilirsiniz " & FolderName
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

[fenerbahcem]

Sayın ; düşünceli

Teşekkür ederim. Elinize Sağlık. Kalın sağlıcakla.