Çözüldü Excel dosyasının formülsüz ve makrosuz kopyasını oluşturma

Katılım
20 Eylül 2005
Mesajlar
119
Excel Vers. ve Dili
2016 - Türkçe
Sub SayfaKorumayiKaldir()
Dim sayfa As Worksheet
'Dim sifre As String
'sifre = InputBox("Sayfa Korumalarını kaldırmak için Şifre Giriniz.", "Şifre Girin")
On Error Resume Next
For Each sayfa In Worksheets
sayfa.Unprotect Password:=sifre
Next sayfa
If Err <> 0 Then
'MsgBox "Yanlış ŞİFRE girdiniz , Sayfa Korumaları kaldırılmadı", vbCritical, "HATA!!!"
End If
On Error GoTo 0
End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bunu korumalı sayfalarda yapamıyoruz. Önce tüm workbook'un korumasını kaldırıp sonra tekrar korumaya alabilirmiyiz?
kod:

Rich (BB code):
Sub deneme()

ThisWorkbook..Protect Password:="10", Structure:=False, Windows:=False ' dosya koruması açmak

Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy

'ActiveWorkbook.Protect Password:="10", Structure:=False, Windows:=False ' dosya koruması açmak

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya_adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & dosya_adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
Worksheets(ActiveSheet.Name).Protect Password:="10", Contents:=False, Scenarios:=False ' sayfa korumasını aç
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete

Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Worksheets(ActiveSheet.Name).Protect Password:="10", Contents:=True, Scenarios:=True ' sayfa korumasını kapat

Application.CutCopyMode = False
Next

ActiveWorkbook.Protect Password:="10", Structure:=True, Windows:=True ' dosya korumasını kapatmak

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


ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

ThisWorkbook.Protect Password:="10", Structure:=True, Windows:=True ' dosya korumasını kapatmak

End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodu yeniden güncelledim
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Bu kodu bir dene
Kod:
Sub deneme()

Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya_adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & dosya_adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete

Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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


ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger


End Sub
Yeni kod ile tablo ve resimlerin silinmesi sorunu düzeldi(y)

Tek sorun kaldı.Koşullu biçimlendirme formüllerini siliyor(y) fakat renklerde gidiyor
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Koşul silinince renklerde silinir.
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Halit Bey bilgilendirme için teşekkür ederim. Elinize sağlık
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,316
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Alternatif,

Kod:
Option Explicit

Sub Formulsuz_ve_Makrosuz_Yedek_Olustur()
    Dim K1 As Workbook, Yedek As Workbook, Sayfa As Worksheet
    Dim Alan As Range, Yol As String, Dosya_Adi As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
        
    Set K1 = ThisWorkbook
    
    K1.Sheets.Copy
    
    Set Yedek = ActiveWorkbook
    
    Yedek.Sheets("ÖNBİLGİ").Delete
    
    For Each Sayfa In Yedek.Worksheets
        With Sayfa.Cells.SpecialCells(xlCellTypeFormulas)
            .Value = .Value
        End With
        For Each Alan In Sayfa.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            Alan.Interior.ColorIndex = Alan.DisplayFormat.Interior.ColorIndex
        Next
        Sayfa.Cells.FormatConditions.Delete
    Next
    
    Yol = K1.Path & Application.PathSeparator
    Dosya_Adi = "Yedek_" & Format(Date, "dd_mm_yy") & "_" & Format(Time, "hh_mm_ss") & ".xlsx"
    
    Yedek.SaveCopyAs Yol & Dosya_Adi
    Yedek.Close False
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
    MsgBox "Dosyanız aşağıdaki klasöre formülsüz ve makrosuz olarak yedeklenmiştir." & vbCrLf & vbCrLf & _
           Yol & Dosya_Adi, vbInformation
End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Halit Bey bilgilendirme için teşekkür ederim. Elinize sağlık

Koşullu biçimlendirmede ofis 2007 ve aşağıdaki sürümlerde DisplayFormat özelliği bulunmadığından ben FormatConditions(1).Interior.ColorIndex özelliği ile kodu yazdım.
aşağıdaki link, irdeleyiniz.
https://support.office.com/en-ie/article/conditional-formatting-compatibility-issues-ef68c97a-1b5e-47eb-9b3f-a548f941df4f

bu kodu bir dene



Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Cells.SpecialCells(xlCellTypeAllFormatConditions)
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
Next
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
 
Son düzenleme:

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Koşullu biçimlendirmede ofis 2007 ve aşağıdaki sürümlerde DisplayFormat özelliği bulunmadığından ben FormatConditions(1).Interior.ColorIndex özelliği ile kodu yazdım.
aşağıdaki link, irdeleyiniz.
https://support.office.com/en-ie/article/conditional-formatting-compatibility-issues-ef68c97a-1b5e-47eb-9b3f-a548f941df4f

bu kodu bir dene



Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Cells.SpecialCells(xlCellTypeAllFormatConditions)
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
Next
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub


Halit Bey yeni kopya oluştu.Birde hata vererek aşağıdaki uyarıyı gösterdi.Yeni kopyada koşullu biçimlendirme formülleri silinmedi
Adsız.png
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Alternatif,

Kod:
Option Explicit

Sub Formulsuz_ve_Makrosuz_Yedek_Olustur()
    Dim K1 As Workbook, Yedek As Workbook, Sayfa As Worksheet
    Dim Alan As Range, Yol As String, Dosya_Adi As String
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
       
    Set K1 = ThisWorkbook
   
    K1.Sheets.Copy
   
    Set Yedek = ActiveWorkbook
   
    Yedek.Sheets("ÖNBİLGİ").Delete
   
    For Each Sayfa In Yedek.Worksheets
        With Sayfa.Cells.SpecialCells(xlCellTypeFormulas)
            .Value = .Value
        End With
        For Each Alan In Sayfa.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            Alan.Interior.ColorIndex = Alan.DisplayFormat.Interior.ColorIndex
        Next
        Sayfa.Cells.FormatConditions.Delete
    Next
   
    Yol = K1.Path & Application.PathSeparator
    Dosya_Adi = "Yedek_" & Format(Date, "dd_mm_yy") & "_" & Format(Time, "hh_mm_ss") & ".xlsx"
   
    Yedek.SaveCopyAs Yol & Dosya_Adi
    Yedek.Close False
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With
   
    MsgBox "Dosyanız aşağıdaki klasöre formülsüz ve makrosuz olarak yedeklenmiştir." & vbCrLf & vbCrLf & _
           Yol & Dosya_Adi, vbInformation
End Sub
Koray Bey alternatif kodla yeni kopya oluşmadı.Hata vererek aşağıdaki uyarıyı gösterdi
Adsız.png
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
excellin hangi sürümünü kullanıyorsunuz
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Evde 2010,işte 2007 sürümü.şuanki denemeleri 2010 excelde yapıyorum
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
bir de bu kodu dene

Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Cells.SpecialCells(xlCellTypeAllFormatConditions)
If hucre.HasFormula = False Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If
Next


ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod çalışmadı ise birde bunu dene

Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

If Val(ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) > 0 Then
adres = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Address
For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1:" & adres).Cells
If hucre.HasFormula =True Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If

Next
End If

ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
 
Son düzenleme:

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
bir de bu kodu dene

Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Cells.SpecialCells(xlCellTypeAllFormatConditions)
If hucre.HasFormula = False Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If
Next


ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
Adsız.png
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
kod çalışmadı ise birde bunu dene

Kod:
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

If Val(ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) > 0 Then
adres = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Address
For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1:" & adres).Cells
If hucre.HasFormula = False Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If

Next
End If

ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
yeni kopya oluştu.makro ve formüller silindi.fakat koşullu biçimlendirme ile oluşan renklerde silindi
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
34 nolu mesajdaki kodu güncelledim bir daha dene
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Eğer olmadıysa bu kodu dene sonuç alamassan kırmızı yerdeki False yazan yeri True yazın

Rich (BB code):
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

If WorksheetFunction.CountA(ActiveWorkbook.Sheets(Sheets(i).Name).Cells) > 0 Then
sat = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Dim hucre As Range

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Range(Cells(1, 1), Cells(sat, sut)).Cells
If hucre.HasFormula = False Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If

Next
End If

ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
219
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
Eğer olmadıysa bu kodu dene sonuç alamassan kırmızı yerdeki False yazan yeri True yazın

Rich (BB code):
Sub deneme()
Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i

Sheets(myArray).Select
Sheets(myArray).Copy
yenidosya_adı = ActiveWorkbook.Name

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name) 'dosya adı
uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name) 'uzanti

If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".xls" Then
FileFormatNum = 56
End If

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Yeni" & Dosya_Adi & sat & uzanti
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Select
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("a1").PasteSpecial Paste:=3

If WorksheetFunction.CountA(ActiveWorkbook.Sheets(Sheets(i).Name).Cells) > 0 Then
sat = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Dim hucre As Range

For Each hucre In ActiveWorkbook.Sheets(Sheets(i).Name).Range(Cells(1, 1), Cells(sat, sut)).Cells
If hucre.HasFormula = False Then
If hucre.FormatConditions.Count > 0 Then
hucre.Interior.ColorIndex = hucre.FormatConditions(1).Interior.ColorIndex
End If
End If

Next
End If

ActiveWorkbook.Sheets(Sheets(i).Name).Cells.FormatConditions.Delete
Range("A2").Select
'ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger, FileFormat:=FileFormatNum

ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & "\" & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger

End Sub
Halit Bey 34 mesajdaki güncellenmiş kodu denedim.yeni kopya oluştu.formüller makrolar silindi.koşullu biçimlendirme formül ve renkleride silindi
38 nolu mesajdaki kodu denedim.yeni kopya oluştu.formüller makrolar silindi.koşullu biçimlendirme formül ve renkleride silindi
38 nolu mesajdaki kodda belirttiğiniz false yazan yeri true olrak değiştirdim.koşullu biçimlendirme formül ve renkleride silindi
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kodlar sizin 1 nolu mesajınızdaki dosyada çalışıyor
sizin örnek dosyanız
 

Ekli dosyalar

Üst