Eşittir (=) ile ilgili sıkıntı

[meleklerim]

Hepimizin bildiği gibi eğer a1 hücresi b1 hücresinin aynısı olması isteniyorsa basit bir şekilde a1 hücresine =B1 yazıp geçiyoruz.
Benim istediğim; B1 hücresinde bir metin varsa ve metin diyelim "Ahmet" şeklinde yazılıysa (bir hecesi farklı renk) aynı biçimin =B1 yazdığım A1 hücresinde de olmasını istiyorum.
Kısaca = formülü sadece veriyi değil biçimi de kapsayacak şekilde nasıl geliştirebiliriz?
Yardımcı olacaklar şimdiden teşekkürler

 

[Korhan Ayhan]

Bu şekilde çalışan bir fonksiyon yoktur.

Makro ile biçim kopyalaması yapabilirsiniz.

 

[meleklerim]

örnek bir makro yayınlayabilir misiniz acaba? Uygulandığı hücredeki kelimlerin hecelerini farklı renkte yapacak. Bana lazım olan 2. ve 4. hecelerin kırmızı olması. 4 heceden fazla kelime yok zaten.

 

[Korhan Ayhan]

Formülleriniz hep eşittir ile başlıyorsa aşağıdaki kod işinizi görecektir.

İşleyiş;

Asıl sayfanızda formülleriniz ve biçimlendirmeleriniz bulunsun.
Asıl sayfanızdaki formüllü hücreleri mouse ile seçip kodu çalıştırın.

Kod çalışmaya başladığında sayfanızın bir kopyasını oluşturacak.
Daha sonra seçili alandaki formüllü hücreleri değere çevirip biçimlendirme yapacak.

Sub BİÇİM_KOPYALA()
    Dim Veri As Range, Adres As String
    
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
    
    For Each Veri In Selection
        If Veri.HasFormula Then
            Adres = Replace(Veri.FormulaLocal, "=", "")
            Range(Adres).Copy
            Veri.PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[meleklerim]

malesef olmadı arkadaşım formüller =düşeyara ile başlıyor, ana tabloda çift renk olan metinler, formülün olduğu hücrede tek renk. Bu makro "400" nolu hata kodu verdi.
Hücrenin birisine bu özelliği katıp, biçim boyacısı ile bu özelliği istdiğimiz hücrelere uygulayacak bir çözüm bulunabilir mi?

 

[Korhan Ayhan]

Kullandığınız DÜŞEYARA formülünü buraya yazabilir misiniz?

Eğer benim bilmediğim ya da aklıma gelmeyen başka bir yöntem yoksa formüllerden kurtulmadan bu işlemi yapamazsınız.

 

[meleklerim]

dosyayı upload ettim.
Sizin eklediğini makro da kayıtlı

https://mega.co.nz/#!nsUTWb5Z!vM-tXeawBpjXf1-oduqnOWKQye8h2-aXEec06dB5q-k

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Kodu çalıştırdığınızda tablonuzda formül kalmayacaktır. Direk değerleri göreceksiniz.

Sub BİÇİM_KOPYALA()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Aranan As Variant, Bul As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("tablo")
    Set S2 = Sheets("Kart")

    Aranan = S2.Range("I1")
    If Aranan = "" Then MsgBox "Lütfen aradığınız değeri giriniz!", vbCritical: Exit Sub
    
    Set Bul = S1.Range("A:A").Find(Aranan, , , xlWhole)
    If Not Bul Is Nothing Then
        S1.Cells(Bul.Row, 2).Copy S2.Range("C2")
        S1.Cells(Bul.Row, 3).Copy S2.Range("E2")
        S1.Cells(Bul.Row, 4).Copy S2.Range("G2")
        S1.Cells(Bul.Row, 5).Copy S2.Range("C4")
        S1.Cells(Bul.Row, 6).Copy S2.Range("E4")
        S1.Cells(Bul.Row, 7).Copy S2.Range("G4")
        S1.Cells(Bul.Row, 8).Copy S2.Range("I4")
        S1.Cells(Bul.Row, 9).Copy S2.Range("C6")
        S1.Cells(Bul.Row, 10).Copy S2.Range("E6")
        S1.Cells(Bul.Row, 11).Copy S2.Range("G6")
        S1.Cells(Bul.Row, 12).Copy S2.Range("I6")
    End If
    
    S2.Range("B1:J6").Font.Name = "Calibri"
    S2.Range("B1:J6").Font.Size = 36

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[meleklerim]

süper oldu, yazı tipini değiştirdim. ancak keşke formüllü olan sayfayı kopyalayıp, kopyaladığı sayfada yapsaydı daha iyi olacaktı. Pazar pazar sizi de meşgul ediyorum, hakkıınızı helal edin

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sayfayı kopyalayarak işlem yapar.

Sub BİÇİM_KOPYALA()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Aranan As Variant, Bul As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("tablo")
    Sheets("Kart").Copy After:=Sheets(ThisWorkbook.Worksheets.Count)
    Set S2 = ActiveSheet
    
    Aranan = S2.Range("I1")
    If Aranan = "" Then MsgBox "Lütfen aradığınız değeri giriniz!", vbCritical: Exit Sub
    
    Set Bul = S1.Range("A:A").Find(Aranan, , , xlWhole)
    If Not Bul Is Nothing Then
        S1.Cells(Bul.Row, 2).Copy S2.Range("C2")
        S1.Cells(Bul.Row, 3).Copy S2.Range("E2")
        S1.Cells(Bul.Row, 4).Copy S2.Range("G2")
        S1.Cells(Bul.Row, 5).Copy S2.Range("C4")
        S1.Cells(Bul.Row, 6).Copy S2.Range("E4")
        S1.Cells(Bul.Row, 7).Copy S2.Range("G4")
        S1.Cells(Bul.Row, 8).Copy S2.Range("I4")
        S1.Cells(Bul.Row, 9).Copy S2.Range("C6")
        S1.Cells(Bul.Row, 10).Copy S2.Range("E6")
        S1.Cells(Bul.Row, 11).Copy S2.Range("G6")
        S1.Cells(Bul.Row, 12).Copy S2.Range("I6")
    End If
    
    S2.Range("B1:J6").Font.Name = "Calibri"
    S2.Range("B1:J6").Font.Size = 36

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[meleklerim]

eline sağlık Korhan bey, çok teşekkürler