Cari isim kısaltma

[Asri]

Ayarlar sayfasında uzun kelime için büyük küçük harf girilebilir özelliği eklendi.
Ayarlar sayfasında uzun kelime için boşluklar otomatik silinecek özelliği eklendi.

WeTransfer | Send Large Files Fast

The simple, quick and secure way to send your files around the world without an account. Share your files, photos, and videos today for free.

we.tl

Sub KelimeKisaltma()
    Dim cümle As String
    Dim kelimeler() As String
    Dim sonuc As String
    Dim i As Integer
    Dim kelime As String, listekelime As String
    
    
    sonsatir = Sheets("Ayarlar").Cells(Sheets("Ayarlar").Rows.Count, "A").End(3).Row
    liste = Sheets("Ayarlar").Range("A2:B" & sonsatir)
   'İlk kaç kelime değişmeyecek
    degismeyecekler = 0 + Sheets("Ayarlar").Range("D2").Value
    
    Range("B:B").ClearContents
    Range("B1").Value = "KISA ALICI ADI"
    sonsatir = Cells(Rows.Count, "A").End(3).Row
 For i1 = 2 To sonsatir
    cümle = BKH(Cells(i1, "A").Value, 2)
    kelimeler = Split(cümle, " ")
    sonuc = ""
    For i = 0 To UBound(kelimeler)
      If i > degismeyecekler - 1 Then
        For j = 1 To UBound(liste)
        kelime = kelimeler(i)
        listekelime = Replace(liste(j, 1), " ", "")
        listekelime = BKH(listekelime, 2)
          If kelime = listekelime Then
               sonuc = sonuc & liste(j, 2)
              Exit For
          End If
        Next j
      Else
        sonuc = sonuc & kelimeler(i) & " "
      End If
    Next i
    Cells(i1, "B").Value = sonuc
 Next i1
 MsgBox ("İşlem tamamlandı")
End Sub

'@Necdet, Büyük küçük harf ve yazım düzeni.
Function BKH(Sozcuk As String, Optional Tip As Integer = 2) As String

    'Tip    1. Küçük Harf
    '       2. Büyük Harf
    '       3. Yazım Düzeni
    
    Sozcuk = Application.WorksheetFunction.Trim(Sozcuk)
    If Tip = 1 Then
        BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
    ElseIf Tip = 2 Then
        BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
    Else
        BKH = Application.WorksheetFunction.Proper(Sozcuk)
    End If
    
End Function

 

[igultekin2000]

Evet haklısınız, kısalacak kelimeleri büyük harfle yazdığımda makro sonuç üretiyor.
Teşekkürler, iyi çalışmalar.

 

[ben28]

Merhabalar,

Hocam ben indiremiyorum süreyi geçmişi. Sizden ricam tekrar yükleyebilir misiniz.

Sub KelimeKisaltma() Dim cümle As String Dim kelimeler() As String Dim sonucuc As String Dim i As Integer Dim kelime As String, listekelime As String sonsatir = Sheets("Ayarlar").Cells(Sheets("Ayarlar").Rows. Count, "A").End(3).Row list = Sheets("Ayarlar").Range("A2:B" & sonsatir) 'İlk kaç kelime değişmeyecek değişmeyecekler = 0 + Sheets("Ayarlar").Range( "D2").Value Range("B:B").ClearContents Range("B1").Value = "KISA ALICI ADI" sonsatir = Cells(Rows.Count, "A").End(3).Row For i1 = 2 To sonsatir cümle = BKH(Cells(i1, "A").Value, 2) kelimeler = Split(cümle, " ") sonuc = "" For i = 0 To UBound(kelimeler) If i > değişmeyecekler - 1 Sonra For j = 1 To UBound(liste) kelime = kelimeler(i) listekelime = Değiştir(liste(j, 1), " ", "") listekelime = BKH(listekelime, 2) If kelime = listekelime Sonra sonuçc = sonuc & list(j, 2) Exit For End If Next j Else sonuc = sonuc & kelimeler(i) & " " End If Next i Cells(i1, "B").Value = sonuc Next i1 MsgBox ("İşlem tamamlandı") End Sub '@Necdet, Büyük küçük harf ve yazı düzeni. Function BKH(Sozcuk As String, Optional Tip As Integer = 2) As String 'Tip 1. Küçük Harf ' 2. Büyük Harf ' 3. Yazım Düzeni Sozcuk = Application.WorksheetFunction.Trim(Sozcuk) If Tip = 1 Sonra BKH = Değerlendir ("=LOWER(" & """" & Sözcük & """" & ")") ElseIf Tip = 2 Then BKH = Evaluate("=UPPER(" & """" & Sözcük & """" & ")") Else BKH = Application.WorksheetFunction.Proper(Sozcuk) End If End Function
[/ALINTI]

 

[ben28]

Merhaba, Yapmış olduğunuz özet üzerinden giderek birkaç nacizane talebim olacak;
Cari Adını Kısaltıp daha sonrasında 2 hücreye uzunluğunda 35'i geçemeyecek şekilde böle biliriz.
Örnek taslağım ektedir.
Yardımcı olursanız sevinirim.

MUTFAK EŞYALARI HEDİYELİK EŞYA REKLAM İNŞAAT OPTİK TEKSTİL KIRTASİYE TİCARET LİMİTED ŞİRKETİ

 

[ben28]

Güncel...

 

[Erkan Akayay]

D2 formülü =SOLDAN(C2;MBUL("/";YERİNEKOY(SOLDAN(C2;35);" ";"/";35-UZUNLUK(YERİNEKOY(SOLDAN(C2;35);" ";""))))-1)

E2 formülü = =SAĞDAN(C2;(UZUNLUK(C2)-UZUNLUK(D2)-1))