Sayfada Düzeni özelleştirilmiş Renkler

[hamitalper]

Herkese Merhaba,

Kullandığım bir dosyada makro ile kopyalayıp yeni bir excele formullerin değer yapıştırılarak aktardığım yeni excel dosyasında dosya dolguları biçimleri bozularak yapıştırıyor orjinalinden farklılaşarak acaba aşağıda paylaştığım özelleştirğim hex kodlarını "123" olarak tanımladığım biçimi bu makroya yansıtabilceğimiz bir kod varmı.

Teşekkürler.

 

[Muzaffer Ali]

Merhaba.
Yapıştırmayı önce norma sonra değer yaparsanız tüm biçimlendirmeler de gider.
Yapamazsanız kodları paylaşın yapalım.

 

[hamitalper]

Muzaffer Bey Merhaba, doğrumu anladım bilmiyorum ama kodları aşağıda paylaşıyorum;
Metin/Arka Plan- Koyu 1 ---- Kırmızı:0 Yeşil:0 Mavi:0
Metin/Arka Plan- Açık 1 ---- Kırmızı:255 Yeşil:255 Mavi:255
Metin/Arka Plan- Koyu 2 ---- Kırmızı:68 Yeşil:84 Mavi:106
Metin/Arka Plan- Açık 2 ---- Kırmızı:255 Yeşil:255 Mavi:255
Vurgu 1 ---- Kırmızı:0 Yeşil:176 Mavi:240
bu hex kodlarını mı sordunuz Saygıdeğer hocam yoksa makroyu mu hocam aşağıda paylaştım teşekkürler sağolun dönüşünüz için

Sub FormulsuzSayfa()
Dim RaporYolAd As String
RaporYolAd = ActiveWorkbook.Path & "\Rapor.xlsx"

Application.ScreenUpdating = False
ActiveSheet.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=RaporYolAd, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True


' Temizlik
Set objMail = Nothing
Set objOutlook = Nothing


MsgBox "Rapor", vbInformation, "Rapor OK"
End Sub

 

[Muzaffer Ali]

ActiveSheet.Cells.Copy

Satırının altına aşağıdaki satırı ekleyin. Herhangi bir satırı silmeyin.

ActiveSheet.Cells.PasteSpecial

Eğer yine olmazsa dosyanızı paylaşın kontrol edelim.

 

[hamitalper]

merhabalar Muzaffer Bey, denedim bu şekli birleştirilmiş hücreleri iptal ediyor. ben örnek bir dosya gönderdim burda mesela makroyu çalışırdığımda orjinal dosya ile biçimler farklılaşmakta şimdiden çok teşekkürler destekleriniz için

 

[Muzaffer Ali]

Gönderdiğiniz dosyada Renkler kısmında tanımladığınız 123 adında renklendirme mevcut değil.
Dosyayı paylaştığınızda bile oradan siliniyor.
Nasıl çözülür bilemedim.

 

[hamitalper]

hocam sayfa düzeni kısmında gözüküyor, burda neler lazım tüm "RGS"kodlarını iletebilirim eğer istediğiniz buysa

 

[Muzaffer Ali]

Dosyayı paylaştığınızda bile oradan siliniyor.

 

[hamitalper]

saygıdeğer hocam şöyle birşey yapsak neden silindiğini anlamadım çünkü, Renkler kısmından renkleri özelleştirden herhangi bir tanımlama yapsanız renk kodlarının ve isminin önemi yok , sizin tanımladığınızı uygulasak ben sonrasında sizin kodladığınıza göre revize etsem, çok teşekkürler ilginiz için

 

[Muzaffer Ali]

Örnek dosyanızdaki kodları aşağıdaki ile değiştirip deneyiniz.

Sub FormulsuzSayfa()
Dim RaporYolAd As String
RaporYolAd = ActiveWorkbook.Path & "\DOSYA.xlsx"

Application.ScreenUpdating = False
ActiveSheet.Copy
ActiveSheet.Cells.Copy
ActiveWorkbook.Theme.ThemeColorScheme.Load (Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=RaporYolAd, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True

    Dim objOutlook As Object
    Dim objMail As Object

    ' Outlook mail oluşturma
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    ' Mail oluşturup dosya ekleniyor
    With objMail
        .To = "test@gmail.com" ' mail gönderilecek kişi
        .Subject = "DOSYA" ' mail konusu
        .Body = "İyi Günler Dileriz." ' mail içeriği
        .Attachments.Add RaporYolAd ' Rapor ek olarak gönderilebilir
        .Display ' E-postayı görüntüle (veya .Send ile gönder)
    End With

    ' Temizlik
    Set objMail = Nothing
    Set objOutlook = Nothing


MsgBox "Rapor .", vbInformation, "Rapor OK"
End Sub

 

[hamitalper]

emeğinize bilginize sağlık Muzaffer bey teşekkür ediyorum