• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

M

MESUT K

Katılım
26 Nisan 2019
Mesajlar
221
Excel Vers. ve Dili
İş'te:Excel 2016 eng
Ev'de:Excel 2013 tr
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:
Merhaba,
İşin içine buton girince makrosuz olmaz diye biliyorum.
Bakalım, belki yanılıyorumdur da bir çözüm gelir.
 
Makrosuz ve formulsuz cok zor olabilceğini sanmıyorum
 
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.
 
Bağlantı ile yapılır ama cok uzun olur gibi :D
 
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
 
valla hocam çok teşekkür ederim hakikaten güzel olmuş.istediğim şekil buydu(y):)
 
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
 
MESUT K' Alıntı:
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
Genişletmek için tıkla ...

Kodun bu bölümünü sil

Kod: 
ActiveSheet.DrawingObjects.Delete
 
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
 
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
 
Ö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.
 
halit3' Alıntı:
Ö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.
Genişletmek için tıkla ...

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)
 
Bunu korumalı sayfalarda yapamıyoruz. Önce tüm workbook'un korumasını kaldırıp sonra tekrar korumaya alabilirmiyiz?
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst