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

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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:

PriveT

Altın Üye
Katılım
8 Ekim 2009
Mesajlar
542
Beğeniler
119
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
7 Mayıs 2019
Mesajlar
40
Beğeniler
0
Excel Vers. ve Dili
Microsoft 2017
Visual Studio 2013-2014-2017-2019
#5
Makrosuz ve formulsuz cok zor olabilceğini sanmıyorum
 

PriveT

Altın Üye
Katılım
8 Ekim 2009
Mesajlar
542
Beğeniler
119
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
7 Mayıs 2019
Mesajlar
40
Beğeniler
0
Excel Vers. ve Dili
Microsoft 2017
Visual Studio 2013-2014-2017-2019
#7
Bağlantı ile yapılır ama cok uzun olur gibi :D
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,835
Beğeniler
915
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
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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):)
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,835
Beğeniler
915
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
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,835
Beğeniler
915
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.
 

MESUT K

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
65
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)
 

hakankilic

Altın Üye
Altın Üye
Katılım
20 Eylül 2005
Mesajlar
102
Beğeniler
3
Excel Vers. ve Dili
2016 - Türkçe
#19
Bunu korumalı sayfalarda yapamıyoruz. Önce tüm workbook'un korumasını kaldırıp sonra tekrar korumaya alabilirmiyiz?
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,835
Beğeniler
915
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