Aşağıdaki kod Sayın Haluk bey tarafından 2005 yılında yazılmıştı. Halen kullanıyorum, kendisine teşekkür ederim.
Ama uzun satırlarda yavaş çalışıyor. Hızlandırmanın bir yolu var mıdır?
Kodun yaptığı iş; adı yazım düzeninde (çift isimli olanlar da dahil), soyadı ise büyük harf yapıyor.
Ama uzun satırlarda yavaş çalışıyor. Hızlandırmanın bir yolu var mıdır?
Kodun yaptığı iş; adı yazım düzeninde (çift isimli olanlar da dahil), soyadı ise büyük harf yapıyor.
Kod:
'*****************************************************************************
'* Excel' de hucrelerde yazılı metinlerin; *
'* - Tum harflerin buyuk harf yapilmasi *
'* - Kelimelerin ilk harflerinin buyuk harf yapilmasi *
'* - Tum harflarin kucuk harf yapilmasi *
'* - Cumle yazim duzeni yapilmasi *
'* *
'* Islevleri, sayfa uzerindeki sag tus menusune ilave edilmistir. *
'* Kodlar, Turkce karakterlerde problem cikartmaz. *
'* *
'* Burasi Excel Vadisi ... *
'* 21/09/2005 *
'* Haluk ® *
'* *
'* Revizyon -1 : 2 veya daha fazla kelimeden olusan metinlerin, *
'* sadece son kelimesinde harflerin, buyuk harfe *
'* cevrilmesi ile ilgili menu ilave edildi. *
'* *
'* *
'* Revizyon -2 : Menu, klavyeden Shift + F3 tusuna her basista degise_ *
'* cek sekilde ayarlandi. (MS Word programindaki gibi) *
'* *
'* 29/01/2006 *
'* Haluk ® *
'*****************************************************************************
' Raider ®
Public j As Integer
'
Sub harfduzeni_ac()
Call SpecialCellMenu
Application.OnKey "+{F3}", "KeyBoardEntry"
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 harfduzeni_kapat()
Application.CommandBars("Cell").Reset
Application.OnKey "+{F3}"
End Sub
'
Sub CaseChange()
Dim lngType As Long, MyRng As Range
Set MyWd = CreateObject("Word.Application")
Set MyDoc = MyWd.Documents.Add
On Error Resume Next
X = CommandBars.ActionControl.Parameter
On Error GoTo 0
If j > 0 Then X = j
Select Case X
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(y)
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
'
Sub KeyBoardEntry()
j = j + 1
If j > 5 Then j = 1
Call CaseChange
End Sub