büyük harf küçük harf fonksiyonu

[umutsert]

merhaba değerli üyeler;

arkadaşlar belli bir hücreye kişinin adını soyadını yazıp entera bastığımda soyadı otomatik olarak büyük harf olsun

kolay gelsin

 

[Orion1]

Buyur çorlu'lu hemşerim.A1:A10 aralığını büyük harfe çeviri.
Kodlar çalışma sayfasının kod bölümünde.
Dosya ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
Application.EnableEvents = True
End Sub

 

[umutsert]

arkadaşım verdiğin hücre aralığına giriyorum ama büyük harfe çevirmiyor dosya aynen senin gönderdiğin gibi yanlış bişeymi yaptık

bide ben şunu istiyorum tam olarak ad soyad giricem ismin baş harfi büyük arada boşluk ve kalan karakterleri büyük yazıcak

 

[Orion1]

arkadaşım verdiğin hücre aralığına giriyorum ama büyük harfe çevirmiyor dosya aynen senin gönderdiğin gibi yanlış bişeymi yaptık

bide ben şunu istiyorum tam olarak ad soyad giricem ismin baş harfi büyük arada boşluk ve kalan karakterleri büyük yazıcak

Makroları etkinleştirdinizmi?
Araçlar==>Makro==>Güvenlik==>Güvenlik düzeyinden en düşük önerilmezi seçip dosyayı kapatıp tekrar açın.Bundan sonra exceliniz makroları kullanabilecektir.:cool.

 

[umutsert]

denedim ama olmuyor birde tam istediğim bu değil ad soyad bilgisinde soyadı büyük yazıcak ismin baş harfinide büyük

umutdastan59@hotmail.com

 

[Orion1]

denedim ama olmuyor birde tam istediğim bu değil ad soyad bilgisinde soyadı büyük yazıcak ismin baş harfinide büyük

umutdastan59@hotmail.com

Dosyayı kapatıp tekrardan açtınızmı?
İstediğinizz değişikliği yaptım.
Dosya ekte.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, deg, deg2 As String
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False

Target.Value = WorksheetFunction.Proper(Target.Value)
deg = Split(Target.Value, " ")
For i = LBound(deg) To UBound(deg) - 1
    deg2 = deg2 & " " & deg(i)
Next
Target.Value = deg2 & " " & UCase(Replace(Replace(deg(UBound(deg)), "ı", "I"), "i", "İ"))
Target.Value = Right(Target.Value, Len(Target.Value) - 1)

Application.EnableEvents = True
End Sub

 

[Orion1]

Bu da kullanıcı tanımlı fonksiyonu KTF.

Function soyad_buyuk(deg As String) As String
Dim i As Integer, deg2, deg3 As String
On Error Resume Next
deg3 = WorksheetFunction.Proper(deg)
deg2 = Split(deg3, " ")
For i = LBound(deg2) To UBound(deg2) - 1
    deg4 = deg4 & " " & deg2(i)
Next
deg3 = deg4 & " " & UCase(Replace(Replace(deg2(UBound(deg2)), "ı", "I"), "i", "İ"))
soyad_buyuk = Right(deg3, Len(deg3) - 1)
End Function

 

[tufan03]

Bu siteden almıştım, eklenti olarak yükledim sürekli kullanıyorum.
Sub Autpen()
Call SpecialCellMenu
End Sub
'
Sub SpecialCellMenu()
Dim cb As CommandBar
Set cb = Application.CommandBars("Cell")
'
Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
MenuObject.Caption = "Change Case...®"
MenuObject.BeginGroup = True
MenuObject.Tag = "MyTagR"
'
For MenuItem = 1 To 5
Set PopItem = MenuObject.Controls.Add(msoControlButton, 1, MenuItem, , True)
PopItem.FaceId = 7
With PopItem
Select Case MenuItem
Case 1
.Caption = "ABC DEF"
Case 2
.Caption = "Abc Def"
Case 3
.Caption = "abc def"
Case 4
.Caption = "Abc def"
Case 5
.Caption = "Abc Def GHI"
End Select
.OnAction = "CaseChange"
End With
Next
Set cb = Nothing
Set PopItem = Nothing
Set MenuObject = Nothing
End Sub
'
Sub Auto_Close()
Application.CommandBars("Cell").Reset
End Sub
'
Sub CaseChange()
Dim lngType As Long, MyRng As Range
Set MyWd = CreateObject("Word.Application")
Set MyDoc = MyWd.Documents.Add

Select Case CommandBars.ActionControl.Parameter
Case 1
lngType = 1
Case 2
lngType = 2
Case 3
lngType = 0
Case 4
lngType = 4
Case 5
For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
Temp = ""
z = ""
c = ""
MyWd.Selection.text = MyRng.text
MyWd.Selection.Range.Case = 2
Temp = MyWd.Selection.text
MyRng = Temp
z = StrReverse(Temp)
x = InStr(1, z, " ")
If x > 0 Then
y = Mid(z, 1, InStr(1, z, " "))
For i = 1 To Len
c = c & WorksheetFunction.Proper(Mid(y, i, 1))
Next
MyRng = Mid(MyRng, 1, Len(MyRng) - x) & StrReverse(c)
End If
End If
Next
GoTo SafeExit:
End Select

For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
MyWd.Selection.text = MyRng.text
MyWd.Selection.Range.Case = lngType
MyRng = MyWd.Selection.text
End If
Next

SafeExit:
MyDoc.Close False
MyWd.Quit
Set MyDoc = Nothing
Set MyWd = Nothing
End Sub

 

[ZİNDAN]

Buyur çorlu'lu hemşerim.A1:A10 aralığını büyük harfe çeviri.
Kodlar çalışma sayfasının kod bölümünde.
Dosya ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
Application.EnableEvents = True
End Sub

Evren bey;
Burada Aynı sayfa üzerinde A1:A10 aralığının yanında birde C10:C20 aralığındada bu özelliğin aktif olmasını istesek, kodun neresine nasıl bir ilave yapmak gerekir.?

Yardımcı olabilirmisiniz.
Teşekkürler.

 

[Orion1]

Evren bey;
Burada Aynı sayfa üzerinde A1:A10 aralığının yanında birde C10:C20 aralığındada bu özelliğin aktif olmasını istesek, kodun neresine nasıl bir ilave yapmak gerekir.?

Yardımcı olabilirmisiniz.
Teşekkürler.

İlgili kodu aşağıdaki ile değeiştiriniz.

If Intersect(Target, range("A1:A10,C1:C10") Is Nothing Then Exit Sub

 

[ZİNDAN]

Teşekkürler Üstadım.

 

[ZİNDAN]

Hata verdi üstadım.Dosyada Then hatası veriyor Evren bey.

Sorun nerede acaba.?
Yanlış yaptığım nedir acaba.?

Ekteki dosyada hata veriyor mesela.!

 

[Orion1]

Dosya ekte.

Private Sub Worksheet_Change(ByVal Target As range)
If Intersect(Target, range("A1:A10,C1:C10")[B][COLOR="Red"])[/COLOR][/B] Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
Application.EnableEvents = True
End Sub

 

[ZİNDAN]

Teşekkürler sayın Evren Gizlen.
Şimdi oldu.Süper çalışıyor.

 

[steppe]

Buyur çorlu'lu hemşerim.A1:A10 aralığını büyük harfe çeviri.
Kodlar çalışma sayfasının kod bölümünde.
Dosya ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = LCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
Application.EnableEvents = True
End Sub

A1:A10 aralığında hücrelere yazılan kelimelerin hepsini küçük harfe dönüştürüyor.Kelimelerin baş harfleri büyük yapılabilir mi?

 

[mustafa1205]

Ekteki Örnek işinize yarayabilir.

 

[steppe]

Ekteki Örnek işinize yarayabilir.

Mustafa1207 Kardeş,
Yardımların için teşekkürler.Hücreye girdiğimiz her kelimenin ilk harfleri nasıl büyük olabilir.Birde Türkçe karekterlere uygun değil sınırım.

 

[Orion1]

A1:A10 aralığında hücrelere yazılan kelimelerin hepsini küçük harfe dönüştürüyor.Kelimelerin baş harfleri büyük yapılabilir mi?

Buyurun.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = Application.Proper(LCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ")))
Application.EnableEvents = True
End Sub

 

[steppe]

Orion1 Kardeş,
Çok teşekkür ederim.

 

[steppe]

Buyurun.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A10]) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Target.Value = Application.Proper(LCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ")))
Application.EnableEvents = True
End Sub

Kodunu butona nasıl uyarlayabiliriz.