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

 

[hamitalper]

Ö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

hocam merhabalar bu kod kendi bilgisayarımda çalışırken, diğer bilgisayarlarda "Path not found" hatası verip biçimi atmıyor diğer bilgisayarlarada "123" renk özelleştirmesini yapmamıza rağmen neden kaynaklanıyor olabilir hata

 

[Muzaffer Ali]

"C:\Users\ OTURUM ADINIZ \AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")

Sizin bilgisayarınızda 123.xml dosyası bu adreste oluşturuluyor.
Diğer bilgisayarların Windows versiyonu farklı olabilir yada bu dosya farklı yerde olabilir.
Diğer bilgisayarlarda 123.xml dosyasının yerini bulup kodda bulunan adresi ona göre düzenleyin.

 

[Muzaffer Ali]

Daha önce "Path not found" hatası verdiğinde Debug tıklatıp kodlarda sarı işaretli kod satırının hangisi olduğunu söyleyiniz.

 

[hamitalper]

"C:\Users\ OTURUM ADINIZ \AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")

Sizin bilgisayarınızda 123.xml dosyası bu adreste oluşturuluyor.
Diğer bilgisayarların Windows versiyonu farklı olabilir yada bu dosya farklı yerde olabilir.
Diğer bilgisayarlarda 123.xml dosyasının yerini bulup kodda bulunan adresi ona göre düzenleyin.

hocam bunu bulmanın kolay bir yolu varmı , AppData uzantısını kendi bilgisayarımdada bulamadım valla kusurma bakmayın sizi çok yordum hakkınızı helal edin saygıdeğeer hocam

 

[hamitalper]

bu şekidle hocam

 

[hamitalper]

hocam çözdüm sanırım çok sağolun

 

[hamitalper]

hocam uzantı yolu doğru herkeste aynı olmasına rağmen hata veriyor

acaba direk bu şekildemi yazsak aslında "USERPROFILE" yazdığımızda herkeste açması lazımdı ortak olduğu için

 

[Muzaffer Ali]

Sub Test()
Range("A1") = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors"
End Sub

Bu kodu herhangi bir yere kopyalayıp çalıştırın.
A1'e doya yolu yazdırılacaktır.

A1'i kopyalayıp dosya gezginine yapıştırıp Enrere basın. Theme Colors klasörüne girmiş olacaksınız.
Eğer girmezse bu klasör yolu yanlış demektir.
O zaman Microsoft'a kadar olan klasöre girmeyi deneyin girerse o klasörde arama kısmına 123.xml yazarak arayın. Bu şekilde 123.xml dosyasının bulunduğu klasörü bulabilirsiniz.

 

[hamitalper]

hocam kusura bakmayın çok rahatsız ettim sizi ama kendi bilgisayarımda çalışıyor, diğer bilgisayarlarda biçimi yapmıyotr herkeste aynı kısa yola atıyor"123" renk özelleştirmesini aynı kısa yola atıyor ama yine aynı "Path not found" hatası veriyor şimdiye kadarki desteklerinizden dolayı çok teşekkürler olmazsa artık boyle kalsın hocam.