Birleştir(f*) işlevinde renkler korunsun!!!

[h.aykol_]

Örnek dosya koydum.birleştir işlevinde renkler korunsun istiyorum!.mümkünmü acaba?

 

[Levent Menteşoğlu]

Fonksiyonlarla mümkün değil ancak VBA ile yapılabilir.

 

[Necdet]

Merhaba,

Örnek olması açısından :

Public Sub Birlestir()
[C6] = [C5] & "-" & [D5] & "-" & [E5] & "-" & [F5] & "-" & [G5] & "-" & [H5]
i = 5
j = 3
For j = j To 8
    If Cells(i, j).Font.ColorIndex > 0 Then
        Renk = Cells(i, j).Font.ColorIndex
        Bas = (j - 2) * 3 - 1
        If j = 1 Then
            Uz = 3
        Else
            Uz = 2
        End If
        With Range("C6").Characters(Bas, Uz).Font
            .Bold = True
            .ColorIndex = Renk
        End With
    End If
Next j
End Sub

 

[h.aykol_]

değerli uzman arkadaş bu renklerin korunması.kople bir excel sayfasında olmasını istersek ne yapmamız lazım.mesela : birleştirme işlemi
[I5] hücresinde olsa= [C5] & "-" & [D5] & "-" & [E5] & "-" & [F5] & "-" & [G5] & "-" & [H5]
ve (c5:c50)arasındaki satırlarda yapsak ve renk değişince bir satır boşluk verse olabilirmi?

 

[Necdet]

ve renk değişince bir satır boşluk verse olabilirmi?

Yukarıdaki açıklamanızı pek anlamadım ama örnek dosyayı inceleyiniz.

D:H sütünu isteğe uyarlanmış 00 şeklinde biçimlendirilmiştir. dolayısıyla metin biçiminden çıkartılmıştır. Doğru mu yaptım bilmiyorum, kolaylık olmasını istedim.

Public Sub Birlestir()
Application.ScreenUpdating = False
Range("I5:I50").ClearContents
Range("I5:I50").Font.ColorIndex = 1
For i = 5 To [C65536].End(3).Row
    
    Cells(i, "I") = Cells(i, "C")
    
    For j = 4 To 8
        Cells(i, "I") = Cells(i, "I") & "-" & Format(Cells(i, j), "00")
    Next j
    
    For j = 3 To 8
        If Cells(i, j).Font.ColorIndex > 0 Then
            Renk = Cells(i, j).Font.ColorIndex
            Bas = (j - 2) * 3 - 1
            If j = 1 Then
                Uz = 3
            Else
                Uz = 2
            End If
            With Range("I" & i).Characters(Bas, Uz).Font
                .Bold = True
                .ColorIndex = Renk
            End With
        End If
    Next j
Next i
End Sub

 

[h.aykol_]

hocam özür dilerim.ben size sorunumu anlatamadım.ama budefa ayrıntılı yazdım.bi daha bi bakarmısınız. şimdiden teşekkür ederim.

 

[h.aykol_]

DeĞerlİ YeŞerten Sİz Olmayinca Bİze Bakan Bİle Yok.!!!

 

[Necdet]

Merhaba,

Dosyanızın orijinal hali ekte olduğu gibi midir?
Renkler sadece E ve F sütunundaki gibi mavi ve kırmızı mıdır?

Keşke dosayanızda olan ve olması gereken şeklinde çözüm önerseydiniz, çok arkadaş ilgilenirdi.

Çözüme ulaştık derken her seferinde yeni şeyler söylüyorsunuz.

 

[Necdet]

Tekrar merhaba,

Yine de birşeyler yapmaya çalıştım.

Public Sub Birlestir()
Application.ScreenUpdating = False
Range("I10:I50").ClearContents
Range("I10:I50").Font.ColorIndex = 1
For i = 10 To [C65536].End(3).Row
    
    Cells(i, "I") = Cells(i, "C")
    
    For j = 4 To 8
        Cells(i, "I") = Cells(i, "I") & "-" & Format(Cells(i, j), "00")
    Next j
    
    For j = 3 To 8
        If Cells(i, j).Font.ColorIndex > 0 Then
            Renk = Cells(i, j).Font.ColorIndex
            Bas = (j - 2) * 3 - 1
            If j = 1 Then
                Uz = 3
            Else
                Uz = 2
            End If
            With Range("I" & i).Characters(Bas, Uz).Font
                .Bold = False
                .ColorIndex = Renk
            End With
        End If
    Next j
Next i
'----------- Satır Aç ------------------
For i = [j65536].End(3).Row To 11 Step -1
    If Cells(i, "F") = 1 Then Rows(i).Insert Shift:=xlDown
Next i
'--------------- Toplamları Yaz
Bas = 10
For i = 10 To [j65536].End(3).Row + 1
    If Cells(i, "J") = "" Then
        Cells(i, "J") = "=SUM(J" & Bas & ":J" & i - 1 & ")"
        Range("J" & i).Font.Bold = True
        Bas = i + 1
    End If
Next i
MsgBox "İşlem Tamam...."
Application.ScreenUpdating = True
End Sub

 

[h.aykol_]

Tek kelimeyle harika olmuş değerli yeşertener.eline sağlık.mükemmelsiniz.!!!!

 

[h.aykol_]

dreğerli yeşertener çok özür diliyorum.

senin yaptığın makro süper ama ben evrakıma uyarlayamadım.kapasite meselesi herhalde.bir daha bakıpta yazdığın makroyu benim evraka uyurlasan.
TEŞEKKÜR EDERİM.

 

[h.aykol_]

Hocam Sİzİ Yordum Ama Artik Bu Şablonda Sadece Siralama Guruplama Ve Gurup Toplami Alacak.belgenİn Asli Bu

 

[Necdet]

Merhaba,

Son sorunuzda birleştirilecek birşey kalmamış ama

Dosyada formüllerin olması kodların uzamasına neden oldu.

 

[h.aykol_]

TeŞekkÜr Ederİm

 

[h.aykol_]

Hocam Senİ Yoruyorum Ama Bİr KÜÇÜk Problem Var

VerdİĞİ Hata İletİsİnİ Ekte Dosyada Sundum.toplamlarin Altina Bİr Toplam Daha Yaparak.dÖngÜsel BaŞvuru İletİsİ Verİyor.