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

Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
Örnek dosya koydum.birleştir işlevinde renkler korunsun istiyorum!.mümkünmü acaba?
 

Levent Menteşoğlu

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
Fonksiyonlarla mümkün değil ancak VBA ile yapılabilir.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Örnek olması açısından :
Kod:
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
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
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

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
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.

Kod:
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
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
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.
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
DeĞerlİ YeŞerten Sİz Olmayinca Bİze Bakan Bİle Yok.!!!
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
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

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Tekrar merhaba,

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

Kod:
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
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
Tek kelimeyle harika olmuş değerli yeşertener.eline sağlık.mükemmelsiniz.!!!!
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
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.
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
Hocam Sİzİ Yordum Ama Artik Bu Şablonda Sadece Siralama Guruplama Ve Gurup Toplami Alacak.belgenİn Asli Bu
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

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

Dosyada formüllerin olması kodların uzamasına neden oldu.
 
Katılım
19 Mayıs 2007
Mesajlar
154
Excel Vers. ve Dili
office 2003
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.
 
Üst