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

[MESUT K]

Herkese Merhaba

Kusuruma bakmayın site içerisinde benzer konuya ulaştım fakat benim istediğim biraz daha farklı olacak.Üstadlarımdan yardım istiyorum

1-İçerisinde 19 çalışma sayfası barındıran bi excel dosyası var
2-ilk çalışma sayfasının adı önbilgi,diğerleri sırayla 1 den başlayıp 18 kadar devam ediyor
3-önbilgi sayfasında bir buton olacak.butona tıkladığımda kalan 1-18 arası bütün çalışma sayfalarını aynı klasör içerisinde formülsüz,makrosuz kopya dosya oluşacak
4-(1-18 arası) çalışma sayfasında koşullu biçimlendirme ile renklendirilmiş satırlar sütunlar ve veriler aynen kopya dosyada oluşacak

 

[hakankilic]

Bana da lazım... Sizin sayenizde bize de faydası olacak.

 

[MESUT K]

güncel

 

[PriveT]

Merhaba,
İşin içine buton girince makrosuz olmaz diye biliyorum.
Bakalım, belki yanılıyorumdur da bir çözüm gelir.

 

[evrensngr]

Makrosuz ve formulsuz cok zor olabilceğini sanmıyorum

 

[PriveT]

Ben soruyu yanlış anlamışım
Makro ve formül kullanmadan kopya oluşturma gibi algılamışım.
Bu sorunuzun büyük ihtimal bir çözümü vardır.

 

[evrensngr]

Bağlantı ile yapılır ama cok uzun olur gibi

 

[halit3]

Bu kodu bir deneyin

Sub deneme()

Klasor = ThisWorkbook.Path
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")

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
Range("A2").Select
ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next

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

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

 

[hakankilic]

Harika olmuş. Elinize sağlık.

 

[halit3]

Harika olmuş. Elinize sağlık.

Teşekkürler iyi çalışmalar

 

[MESUT K]

valla hocam çok teşekkür ederim hakikaten güzel olmuş.istediğim şekil buydu

 

[MESUT K]

Halit hocam kod çok iyi çalışıyor.Yeni kopya oluşurken bir önceki dosyada bulunan resimler yeni kopyada yok oluyor.Bununla ilgili yardımcı olabilirseniz çok memnun olurum

 

[halit3]

Halit hocam kod çok iyi çalışıyor.Yeni kopya oluşurken bir önceki dosyada bulunan resimler yeni kopyada yok oluyor.Bununla ilgili yardımcı olabilirseniz çok memnun olurum

Kodun bu bölümünü sil

ActiveSheet.DrawingObjects.Delete

 

[MESUT K]

Kodun bu bölümünü sil

ActiveSheet.DrawingObjects.Delete

"ActiveSheet.DrawingObjects.Delete" silince değişiklik olmadı

 

[MESUT K]

Bir sorum daha olacak

ekteki dosyada önbilgi ve diğer 1 den 18 kadar çalışma sayfası var.

ben kodu başka dosyaya uyarlamak istediğimde ;
butonun olduğu sayfa önbilgi
diğer kopyalanmak istenen sayfa adları ( 1 den 18 kadar değilde) başka isimde çalışma sayfaları olunca kod hata veriyor

 

[MESUT K]

Son olarak kod yeni kopyada koşullu biçimlendirme formüllerini silmiyor. Koşullu biçimlendirmenin oluşturduğu renkler gitmemeli,koşullu biçimlendirme formülleri silinmeli.bunun haricinde eksik yok

 

[halit3]

Örnek dosyanızda "ÖNBİLGİ" sayfası vardı kod bu sayfa dışındaki bütün sayfaları kopyalıyor
siz başka dosyada kodu çalıştırdığınızda bu sayfa yoksa kod hata verecektir

If Sheets(i).Name = "ÖNBİLGİ" Then

yukarıdaki kodun sayfa ismini diğer dosyada da değiştirmelisiniz.

 

[MESUT K]

Örnek dosyanızda "ÖNBİLGİ" sayfası vardı kod bu sayfa dışındaki bütün sayfaları kopyalıyor
siz başka dosyada kodu çalıştırdığınızda bu sayfa yoksa kod hata verecektir

If Sheets(i).Name = "ÖNBİLGİ" Then

yukarıdaki kodun sayfa ismini diğer dosyada da değiştirmelisiniz.

Bu sorun halloldu.


"ActiveSheet.DrawingObjects.Delete" kodu silince değişiklik olmuyor
Sorun 1-Başka bir dosyada denediğimde "tablo " ve "resimler" siliniyor
Sorun 2-Koşullu biçimlendirme ile renklendirilme yapmayı sağlayan kural formülleri silinmedi.(formüller silinmeli renklendirme gitmemeli)

 

[hakankilic]

Bunu korumalı sayfalarda yapamıyoruz. Önce tüm workbook'un korumasını kaldırıp sonra tekrar korumaya alabilirmiyiz?

 

[halit3]

Bu kodu bir dene

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