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

hakankilic · 18 Mayıs 2019

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 · 18 Mayıs 2019

hakankilic' Alıntı:
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 · 18 Mayıs 2019

Kodu yeniden güncelledim

MESUT K · 18 Mayıs 2019

halit3' Alıntı:

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

Tek sorun kaldı.Koşullu biçimlendirme formüllerini siliyor

fakat renklerde gidiyor

halit3 · 18 Mayıs 2019

Koşul silinince renklerde silinir.

MESUT K · 19 Mayıs 2019

Halit Bey bilgilendirme için teşekkür ederim. Elinize sağlık

Korhan Ayhan · 19 Mayıs 2019

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 · 19 Mayıs 2019

MESUT K' Alıntı:
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

MESUT K · 19 Mayıs 2019

halit3' Alıntı:

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

MESUT K · 19 Mayıs 2019

Korhan Ayhan' Alıntı:

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

halit3 · 19 Mayıs 2019

excellin hangi sürümünü kullanıyorsunuz

MESUT K · 19 Mayıs 2019

Evde 2010,işte 2007 sürümü.şuanki denemeleri 2010 excelde yapıyorum

halit3 · 19 Mayıs 2019

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 · 19 Mayıs 2019

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

MESUT K · 19 Mayıs 2019

halit3' Alıntı:

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

MESUT K · 19 Mayıs 2019

halit3' Alıntı:

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 · 19 Mayıs 2019

34 nolu mesajdaki kodu güncelledim bir daha dene

halit3 · 19 Mayıs 2019

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 · 19 Mayıs 2019

halit3' Alıntı:

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 · 19 Mayıs 2019

kodlar sizin 1 nolu mesajınızdaki dosyada çalışıyor
sizin örnek dosyanız

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

hakankilic

halit3

Uzman

halit3

Uzman

MESUT K

halit3

Uzman

MESUT K

Korhan Ayhan

Administrator

halit3

Uzman

MESUT K

MESUT K

halit3

Uzman

MESUT K

halit3

Uzman

halit3

Uzman

MESUT K

MESUT K

halit3

Uzman

halit3

Uzman

MESUT K

halit3

Uzman

Ekli dosyalar