Metin Kısaltma

[mbldn]

Arkadaşlar Merhaba;
belki basit bir soru ama şu an beynim durmuş durumda bir hücrede bulunan metin dizesini başka bir hücrede nasıl (kelimelerin ilk ve büyük harflerini alarak) kısaltabiliriz.
örneğin a1 hücremiz "Yarın Okula Gidiyorum" olsun
bunu b1 hücresine "YOG" olarak yazdırabiliriz?
saygılar...

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

Sub BuyukHarfAl()
 
    Dim d As Object
 
    Set d = CreateObject("VBScript.Regexp")
    
    d.Pattern = "[^A-Z\Ç\Ğ\İ\Ö\Ş\Ü ]"
    d.Global = True
    
    Range("B1") = Replace(d.Replace(Range("A1"), ""), " ", "")
 
    Set d = Nothing
 
End Sub

.

 

[İhsan Tank]

Arkadaşlar Merhaba;
belki basit bir soru ama şu an beynim durmuş durumda bir hücrede bulunan metin dizesini başka bir hücrede nasıl (kelimelerin ilk ve büyük harflerini alarak) kısaltabiliriz.
örneğin a1 hücremiz "Yarın Okula Gidiyorum" olsun
bunu b1 hücresine "YOG" olarak yazdırabiliriz?
saygılar...

Merhaba
Alternatif Olsun

Option Explicit
Sub kısalt_61()
Dim ts, kaplan, trabzonspor, bordo
trabzonspor = MsgBox("Verileri Kısaltıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
Range("B:B").ClearContents
For ts = 1 To Cells(65536, "A").End(xlUp).Row
Range("A" & ts).Copy Destination:=Range("C" & ts)
Range("C" & ts).TextToColumns Destination:=Range("C" & ts)
For kaplan = 3 To Cells(ts, 256).End(xlToLeft).Column
bordo = bordo & Left(Cells(ts, kaplan), 1)
Cells(ts, "B") = bordo
Cells(ts, kaplan) = ""
Next
Next
Application.ScreenUpdating = True
MsgBox "Verileri Kısalttım", vbInformation, "Bitiş"
End Sub

 

[mancubus]

Function FirstLetters(rng As Range, Optional Words As Long = -1) As String
'http://www.ozgrid.com/forum/showthread.php?t=50353&page=1

    Dim arrWords
    Dim I As Long
    Dim lngCount As Long
     
    arrWords = Split(rng, " ")
     
    If IsArray(arrWords) Then
        For I = LBound(arrWords) To UBound(arrWords)
            FirstLetters = FirstLetters & Left(arrWords(I), 1)
            lngCount = lngCount + 1
            If Words > 0 And lngCount >= Words Then Exit For
        Next I
    Else
        FirstLetters = Left(arrWords, 1)
    End If
     
End Function

hücredeki bütün kelimelrin ilk harflerini alarak tek bir kelime olarak birleştiren bir KTF.

 

[mbldn]

Merhaba,

Bu şekilde deneyiniz.

Sub BuyukHarfAl()
 
    Dim d As Object
 
    Set d = CreateObject("VBScript.Regexp")
    
    d.Pattern = "[^A-Z\Ç\Ğ\İ\Ö\Ş\Ü ]"
    d.Global = True
    
    Range("B1") = Replace(d.Replace(Range("A1"), ""), " ", "")
 
    Set d = Nothing
 
End Sub

.

Teşekkür ederim.

 

[mbldn]

Merhaba
Alternatif Olsun

Option Explicit
Sub kısalt_61()
Dim ts, kaplan, trabzonspor, bordo
trabzonspor = MsgBox("Verileri Kısaltıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
Range("B:B").ClearContents
For ts = 1 To Cells(65536, "A").End(xlUp).Row
Range("A" & ts).Copy Destination:=Range("C" & ts)
Range("C" & ts).TextToColumns Destination:=Range("C" & ts)
For kaplan = 3 To Cells(ts, 256).End(xlToLeft).Column
bordo = bordo & Left(Cells(ts, kaplan), 1)
Cells(ts, "B") = bordo
Cells(ts, kaplan) = ""
Next
Next
Application.ScreenUpdating = True
MsgBox "Verileri Kısalttım", vbInformation, "Bitiş"
End Sub

teşekkür ederim

 

[mbldn]

Function FirstLetters(rng As Range, Optional Words As Long = -1) As String
'http://www.ozgrid.com/forum/showthread.php?t=50353&page=1

    Dim arrWords
    Dim I As Long
    Dim lngCount As Long
     
    arrWords = Split(rng, " ")
     
    If IsArray(arrWords) Then
        For I = LBound(arrWords) To UBound(arrWords)
            FirstLetters = FirstLetters & Left(arrWords(I), 1)
            lngCount = lngCount + 1
            If Words > 0 And lngCount >= Words Then Exit For
        Next I
    Else
        FirstLetters = Left(arrWords, 1)
    End If
     
End Function

hücredeki bütün kelimelrin ilk harflerini alarak tek bir kelime olarak birleştiren bir KTF.

teşekkür ederim

 

[İhsan Tank]

teşekkür ederim

Rica ederim
Alternatif üreten Sayın : Ömer Hocam'a ve Sayın : mancubus'ada teşekkür ederim.
:yazici: