hücre birleştirme

[greengarden77]

merhaba,
arkadaslar a1 hücresini ile b1 hüscesi ile , c1 hücresinde birlestiryorun fakat benim isteğim a1 hüsresindeki yazı karekteri ve punto su c1 hücresindede aynı sı olsun nasıl yapabilirim? yani tek bir hücrede 2 farklı yazı karekteri ve farklı puntolarda yazı yazabilirmiyim?

 

[Ergün Güler]

merhaba,
arkadaslar a1 hücresini ile b1 hüscesi ile , c1 hücresinde birlestiryorun fakat benim isteğim a1 hüsresindeki yazı karekteri ve punto su c1 hücresindede aynı sı olsun nasıl yapabilirim? yani tek bir hücrede 2 farklı yazı karekteri ve farklı puntolarda yazı yazabilirmiyim?

Selam,
örnek kod aşağıdaki gibidir.
A1 ve B1 hücresini C1'de birleştirir ve ayrı ayrı bicimlendirir.

Sub birlestir_ve_bicimlendir()

deg1 = Range("A1")
deg2 = Range("B1")
Set yer = ActiveSheet.Range("C1")

deg1_ln = Len(deg1)
deg2_ln = Len(deg2)

yer.Value = deg1 + deg2


    With yer.Characters(Start:=1, Length:=deg1_ln).Font
        .Name = "Arial Tur"
        .FontStyle = "Normal"
        .Size = 10
        .Bold = True
        .ColorIndex = 3
    End With
    With yer.Characters(Start:=deg1_ln + 1, Length:=deg2_ln).Font
        .Name = "Arial Tur"
        .FontStyle = "İtalik"
        .Size = 10
        .Bold = False
        .ColorIndex = 5
    End With
  
End Sub

 

[greengarden77]

Ergün bey öncelikle cok teşekurler, kod yazacagınızı düşünmemiştim , benim sayfada 2000 tane veri var bunlar aynı sutunlarda c1 den c2000 e kadar işlem yapması gerekiyor, ve a1 ie b1 arasında 10 boşluk yapabilirmisiniz?

teşekurler,

 

[Ergün Güler]

Ergün bey öncelikle cok teşekurler, kod yazacagınızı düşünmemiştim , benim sayfada 2000 tane veri var bunlar aynı sutunlarda c1 den c2000 e kadar işlem yapması gerekiyor, ve a1 ie b1 arasında 10 boşluk yapabilirmisiniz?

teşekurler,

Selam,
Örnek dosya eklemediğiniz için, verdiğiniz 1 adet örnek için ve size fikir vermesi için böyle bir kodlama yaptım. siz şunu mu istiyorsunuz?

A + 10 boşluk + B = C
Aralık A1'den en son dolu satıra kadar olacak.
Peki A veya B 'de boş veri var mı? boş olursa ne olacak?

Cevaplayınız. Ona göre kod yazalım.

 

[Ergün Güler]

Selam,

Sub birlestir_ve_bicimlendir()
Dim syf As Worksheet
Dim yer As Range
Dim deg1, deg2, bsluk As String
Dim deg1_ln, deg2_ln, bsluk_ln As Long

Set syf = ThisWorkbook.Sheets("Sayfa1")

syf_son = syf.Range("A65536").End(3).Row

syf.Columns(3).Clear
For i = 1 To syf_son
Set yer = syf.Cells(i, "C")

deg1 = syf.Cells(i, "A")
deg2 = syf.Cells(i, "B")
'bsluk = "          "
bsluk = Chr(10)

deg1_ln = Len(deg1)
deg2_ln = Len(deg2)
bsluk_ln = Len(bsluk)

yer.Value = deg1 & bsluk & deg2 'yanyana


    With yer.Characters(Start:=1, Length:=deg1_ln).Font
        .Name = "Arial Tur"
        .FontStyle = "Normal"
        .Size = 10
        .Bold = True
        .ColorIndex = 3
    End With
    With yer.Characters(Start:=deg1_ln + bsluk_ln + 1, Length:=deg2_ln).Font
    
        .Name = "Arial Tur"
        .FontStyle = "İtalik"
        .Size = 10
        .Bold = False
        .ColorIndex = 5
    End With
  
Next
  
MsgBox "Sayın " & Environ("username") & "," & vbLf _
& "Hücre Birleştirme ve Biçimlendirme İşlemi Tamamlanmıştır.", vbInformation, "BİRLEŞTİRME İŞLEMİ"
End Sub

 

[greengarden77]

Ergün bey,
A + 10 boşluk + B = C
dediğiniz gibi olcak boşluları sonra ben ayarlayabilirim dimi, çünku hücreyi ortalama yapıcam ona göre boşlukları düzetlebilirim , a ve b de boş veri yok
veri aralıgı 2000 e kadar olacak


tesekurller, cok sağolun

 

[greengarden77]

ergün bey cok teşekurler olmus cok sagolun

 

[Ergün Güler]

Ergün bey,
A + 10 boşluk + B = C
dediğiniz gibi olcak boşluları sonra ben ayarlayabilirim dimi,

Selam,
Evet. kodlardaki

bsluk="        "

kısmından istediğiniz gibi ayarlaya bilirsiniz.

çünku hücreyi ortalama yapıcam ona göre boşlukları düzetlebilirim , a ve b de boş veri yok

Ben olsam C sütununda birleştirilen verileri alt alta yapardım yine de siz bilirisiniz. Yani şu şekil:

'bsluk = "          " 'yerine
[COLOR="Red"]bsluk = Chr(10)[/COLOR] 'kullanın

veri aralıgı 2000 e kadar olacak
tesekurller, cok sağolun

Zaten kodlardaki

syf_son = syf.Range("A65536").End(3).Row

satırı kodların en son dolu satıra kadar çalışmasını sağlıyor.

(Not: 5.mesajımdaki kodlarda küçük problemler vardı. düzelttim. Güncellersiniz)

İyi çalışmalar.

 

[Ömer]

Merhaba,

Bende birşeyler karalamıştım, boşa gitmesin. Alternatif olarak kullanabilirsiniz.

Sub Birlestir()
    Dim i As Long, bOsluk As String
 
    bOsluk = Application.Rept(" ", 10)
 
    Application.ScreenUpdating = False
 
    [C:C].Clear
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        With Cells(i, "C")
            .Value = Cells(i, "A") & bOsluk & Cells(i, "B")
 
            With .Characters(1, Len(Cells(i, "A"))).Font
                .Bold = False
                .ColorIndex = 3
            End With
 
            With .Characters(Len(Cells(i, "A")) + Len(bOsluk) + 1, _
                            Len(Cells(i, "B"))).Font
                .Bold = True
                .ColorIndex = 5
            End With
 
        End With
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.