ilk karekteri büyütme ve kalın yapma

[AYBORA01]

merhaba elimde 2500 kişinin bulunduğu bir liste var ve ben bulistede bulunan kişilerin adlarının ilk harflerinin 16 karekter büyüklüğünde ve kalın yapmak istiyorum nasıl yapacağım konusunda yardımcı olurmusunuz.



örnek

hakan
ahmet
mehmet
jale
sezen

hakan
ahmet
mehmet
jale
sezen

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub karakter()
Application.ScreenUpdating = False
For i = 1 To Cells(65536, "A").End(xlUp).Row
    If Cells(i, "A").Value <> "" Then
        ilk = Left(Cells(i, "A").Value, 1)
        son = Right(Cells(i, "A").Value, Len(Cells(i, "A").Value) - 1)
        Cells(i, "A").Value = ilk & son
        Range("A" & i).Characters(Start:=1, Length:=1).Font.Size = 16
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı"
End Sub

 

[AYBORA01]

evren hocam teşekkür ederim ancak bir problem var tek sutun olunca gayet güzel çalışıyor ancak 1 den fazla sutun olunca ilk sutundaki bütün karekterleri 16 karekter büyütüyor

 

[Orion1]

bende bilmiyorum neden böyle oluyor.ilk defa çalıştırıldığında doğru sonuç veriyor ikinci defa çalıştırıldığıda ise bütün karakterleri büyük yapıyor.O zaman çalıştırmadan önce sütundaki karakterleri önce küçültün sonrada kodu çalıştırın.

 

[yeniyetme]

arkadaşlar ben bir çözüm buldum galiba

Sub karakter()
Application.ScreenUpdating = False
For i = 1 To Cells(65536, "A").End(xlUp).Row
If Cells(i, "A").Value <> "" Then
ilk = Left(Cells(i, "A").Value, 1)
son = Right(Cells(i, "A").Value, Len(Cells(i, "A").Value) - 1)
Cells(i, "A").Value = ilk & son
Range("A" & i).Characters(Start:=1, Length:=1).Font.Size = 16
Range("A" & i).Characters(Start:=2, Length:=20).Font.Size = 8
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı"
End Sub

kodları bu şekilde değiştirin..

 

[Orion1]

arkadaşlar ben bir çözüm buldum galiba

Sub karakter()
Application.ScreenUpdating = False
For i = 1 To Cells(65536, "A").End(xlUp).Row
If Cells(i, "A").Value <> "" Then
ilk = Left(Cells(i, "A").Value, 1)
son = Right(Cells(i, "A").Value, Len(Cells(i, "A").Value) - 1)
Cells(i, "A").Value = ilk & son
Range("A" & i).Characters(Start:=1, Length:=1).Font.Size = 16
Range("A" & i).Characters(Start:=2, Length:=20).Font.Size = 8
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı"
End Sub

kodları bu şekilde değiştirin..

Tamam şimdi oldu.Sayın yeni yetmenin bulduğu düzendeki kodlar için aşağıdaki değişikliği yaparak deneyiniz.

Sub karakter()
Application.ScreenUpdating = False
For i = 1 To Cells(65536, "A").End(xlUp).Row
If Cells(i, "A").Value <> "" Then
Range("A" & i).Characters(Start:=1, Length:=1).Font.Size = 16
Range("A" & i).Characters(Start:=2, Length:=[B][COLOR="Red"]Len(Cells(i, "A").Value) - 1[/COLOR][/B]).Font.Size = 8
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı"
End Sub

 

[Necdet]

Merhaba,

Sub karakter()
Application.ScreenUpdating = False
For i = 1 To [A65536].End(3).Row
        Range("A" & i).Characters(Start:=1, Length:=1).Font.Size = 16
        Range("A" & i).Characters(Start:=1, Length:=1).Font.Bold = True
Next i
End Sub