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

Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#1
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
 

Ekli dosyalar

Son düzenleme:
Katılım
8 Ekim 2009
Mesajlar
392
Beğeniler
84
Excel Vers. ve Dili
Office 2010 & 2016
#4
Merhaba,
İşin içine buton girince makrosuz olmaz diye biliyorum.
Bakalım, belki yanılıyorumdur da bir çözüm gelir.
 
Katılım
8 Ekim 2009
Mesajlar
392
Beğeniler
84
Excel Vers. ve Dili
Office 2010 & 2016
#6
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.
 
Katılım
18 Ocak 2008
Mesajlar
11,733
Beğeniler
892
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#8
Bu kodu bir deneyin

Kod:
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
 
Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#11
valla hocam çok teşekkür ederim hakikaten güzel olmuş.istediğim şekil buydu(y):)
 
Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#12
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
 
Katılım
18 Ocak 2008
Mesajlar
11,733
Beğeniler
892
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#13
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

Kod:
ActiveSheet.DrawingObjects.Delete
 
Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#15
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
Adsız.png
 
Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#16
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
 
Katılım
18 Ocak 2008
Mesajlar
11,733
Beğeniler
892
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#17
Ö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

Kod:
If Sheets(i).Name = "ÖNBİLGİ" Then
yukarıdaki kodun sayfa ismini diğer dosyada da değiştirmelisiniz.
 
Katılım
26 Nisan 2019
Mesajlar
57
Beğeniler
3
Excel Vers. ve Dili
İş'te:Excel 2007 eng
Ev'de:Excel 2010 tr
#18
Ö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

Kod:
If Sheets(i).Name = "ÖNBİLGİ" Then
yukarıdaki kodun sayfa ismini diğer dosyada da değiştirmelisiniz.
Bu sorun halloldu.(y)


"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)
 
Katılım
18 Ocak 2008
Mesajlar
11,733
Beğeniler
892
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#20
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
 
Üst