• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Uzunluk 40 tan küçükse aynısını yaz

C

cebelitarık

Katılım
12 Kasım 2007
Mesajlar
327
Excel Vers. ve Dili
excel 2003
Forumun değerli üyeleri

Şöyle bir kod nasıl yazılır.
40 karekterden uzun olan şirket isimlerini 40 karekterle sınırlamam gerekiyor.
Ancak 40 karakterden uzun olan şirket isimlerinin sol başından 32 karekter alıp devamına da bir boşluk ve " LTD.ŞTİ" eklemek istiyorum.

"Sayfa1" in change olayına:
Sayfa1 "L2:L65536" hücre aralığına yazılan cümlenin karekter sayısı 40'a eşit ve küçükse aynı veriyi "K" sutunu aynı satıra yaz.
Değilse soldan 32 tane karekter al ve devamına " LTD.ŞTİ" yaz.
"L2:L65536" aralığında herhangi bir işlem yapılmazsa makro çalışmasın.


Alternatif olarak yukardaki kodun biraz daha gelişmişi olarak:
"Sayfa1" in change olayına:
Sayfa1 "L2:L65536" hücre aralığına yazılan cümlenin karekter sayısı 40'a eşit ve küçükse aynı veriyi "K" sutunu aynı satıra yaz.
Değilse L2:L65536" hücre aralığına yazılan cümlenin uzunluğu hesaplanacak ve,
Örneğin: yazılan cümle uzunluğu 42 karekter ise

42-7 = 35 (Çıkarttığımız "7" sayısı daima sağ baştan alacağımız karekter sayısını temsil etmektedir.)
42-40 = 2 (Çıkarttığımız "40" sayısı daima "K" sütununa yazılması gereken standart uzunluğu temsil etmektedir.)
35-2 = 33 (Çıkarttığımız "2" sayısı 40 karekterden fazla karekter sayısını temsil etmektedir.)
33-1=32 (Çıkarttığımız "1" sayısı araya konacak boşluğu temsil etmektedir.)

Buna göre sol baştan 32 karekter ve bir boşluk olmak üzere toplam 33 karekter ve sağ baştan da 7 karekter ilave olarak yazılacak.
Toplam 40 karekter olacak.

Örneğin şirket ismi şöyle olsun:
QWERTY UIOPĞÜ ASDFGH JKLŞİZ XCVBNM LTD.ŞTİ = Cümle karekter sayısı (boşluklar dahil) 42 karekterdir.

Şirket isminin "K" sütununa yazılacağı yeni şekli aşağıdaki şekilde olacaktır.
QWERTY UIOPĞÜ ASDFGH JKLŞİZ XCVB LTD.ŞTİ (Üstteki orjinal şirket isminden fazladan "NM" karekterleri yutulacak.
"L2:L65536" aralığında herhangi bir işlem yapılmazsa makro çalışmasın.

Her iki alternatifinde kodlarını rica ediyorum.
Saygılarımla
 
Son düzenleme:
cebelitarık' Alıntı:
Forumun değerli üyeleri

Şöyle bir kod nasıl yazılır.
40 karekterden uzun olan şirket isimlerini 40 karekterle sınırlamam gerekiyor.
Ancak 40 karakterden uzun olan şirket isimlerinin sol başından 32 karekter alıp devamına da bir boşluk ve " LTD.ŞTİ" eklemek istiyorum.

"Sayfa1" in change olayına:
Sayfa1 "L2:L65536" hücre aralığına yazılan cümlenin karekter sayısı 40'a eşit ve küçükse aynı veriyi "K" sutunu aynı satıra yaz.
Değilse soldan 32 tane karekter al ve devamına " LTD.ŞTİ" yaz.
"L2:L65536" aralığında herhangi bir işlem yapılmazsa makro çalışmasın.
Genişletmek için tıkla ...

Selam,

İlgili sayfanın kod sayfasına:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
son = Range("L65536").End(3).Row

If Intersect(Target, Range("L2:L65536")) Is Nothing Then Exit Sub
sat = Target.Row

If Len(Range("L" & sat)) > 40 Then
Range("K" & sat) = Mid(Range("L" & sat), 1, 32) & " LTD.ŞTİ."
Else
Range("K" & sat) = Range("L" & sat)
End If

End Sub

Tek seferde yapmak isterseniz, Bir Modül ekleyip, modül kod sayfasına:
Kod: 
Sub ad_kırp()

son = Range("L65536").End(3).Row

For sat = 2 To son
If Len(Range("L" & sat)) > 40 Then

Range("K" & sat) = Mid(Range("L" & sat), 1, 32) & " LTD.ŞTİ."
Else
Range("K" & sat) = Range("L" & sat)
End If

Next

MsgBox "Şirket Adları Uzunlukları Yeniden Düzenlenmiştir", vbInformation, "KIRPMA İŞlEMİ"
End Sub

İyi çalışmalar.
 
Son düzenleme:
Ben de şöyle bir şey düşündüm ama işinize yarar mı bilmiyorum;

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
If Intersect(Target, [L2:L65536]) Is Nothing Then Exit Sub
Target.Offset(0, -1).FormulaR1C1 = "=CONCATENATE(LEFT(RC[1],32),"" LTD.ŞTİ"")"
son:
End Sub
 
Sayın Ergün Güler
İlginiz ve çabuk cevabınız için çok teşekkür ederim.
Acaba sorumun alternatif ikinci kısmı içinde bir çözüm üretebilirmisiniz.
Herzaman isimler limited şirket olmayabiliyor bazan Ananim şirket bazende kooperatif olabiliyor. Alttaki çözüm üretilirse bu konuda çözülmüş olacak.
Ayrıca birinci change olayı çözüm makrosunda :
son = Range("L65536").End(3).Row
satırının gereiğini anlayamadım. herhalde gereksiz bir satır?
Saygılarımla


Alternatif olarak yukardaki kodun biraz daha gelişmişi olarak:
"Sayfa1" in change olayına:
Sayfa1 "L2:L65536" hücre aralığına yazılan cümlenin karekter sayısı 40'a eşit ve küçükse aynı veriyi "K" sutunu aynı satıra yaz.
Değilse L2:L65536" hücre aralığına yazılan cümlenin uzunluğu hesaplanacak ve,
Örneğin: yazılan cümle uzunluğu 42 karekter ise

42-7 = 35 (Çıkarttığımız "7" sayısı daima sağ baştan alacağımız karekter sayısını temsil etmektedir.)
42-40 = 2 (Çıkarttığımız "40" sayısı daima "K" sütununa yazılması gereken standart uzunluğu temsil etmektedir.)
35-2 = 33 (Çıkarttığımız "2" sayısı 40 karekterden fazla karekter sayısını temsil etmektedir.)
33-1=32 (Çıkarttığımız "1" sayısı araya konacak boşluğu temsil etmektedir.)

Buna göre sol baştan 32 karekter ve bir boşluk olmak üzere toplam 33 karekter ve sağ baştan da 7 karekter ilave olarak yazılacak.
Toplam 40 karekter olacak.

Örneğin şirket ismi şöyle olsun:
QWERTY UIOPĞÜ ASDFGH JKLŞİZ XCVBNM LTD.ŞTİ = Cümle karekter sayısı (boşluklar dahil) 42 karekterdir.

Şirket isminin "K" sütununa yazılacağı yeni şekli aşağıdaki şekilde olacaktır.
QWERTY UIOPĞÜ ASDFGH JKLŞİZ XCVB LTD.ŞTİ (Üstteki orjinal şirket isminden fazladan "NM" karekterleri yutulacak.
"L2:L65536" aralığında herhangi bir işlem yapılmazsa makro çalışmasın.
 
Son düzenleme:
cebelitarık' Alıntı:
Sayın Ergün Güler
İlginiz ve çabuk cevabınız için çok teşekkür ederim.
Acaba sorumun alternatif ikinci kısmı içinde bir çözüm üretebilirmisiniz.
Herzaman isimler limited şirket olmayabiliyor bazan Ananim şirket bazende kooperatif olabiliyor. Alttaki çözüm üretilirse bu konuda çözülmüş olacak.
Saygılarımla
Genişletmek için tıkla ...
Selam,
Ben teşekkür ederim. Şöyle birşey mi istiyorsunuz?

GULER........................................ LTD.ŞTİ. ise
GULER........................ LTD.ŞTİ. olacak
GULER........................................ A.Ş. ise
GULER.............................. A.Ş. olacak.

fakat soldan 32 tane sağdan 7 tane sabit kalsın aradakilerden kırsın istiyorsunuz. bunu yapabiliriz. Ancak. A.Ş. karakteri boşluk ile 5 karakter yapıyor.

İlgili sayfanın kod sayfasına:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
son = Range("L65536").End(3).Row

If Intersect(Target, Range("L2:L65536")) Is Nothing Then Exit Sub
sat = Target.Row

If Len(Range("L" & sat)) > [COLOR="red"]40[/COLOR] Then
Range("K" & sat) = [COLOR="red"]Mid(Range("L" & sat), 1, 32)[/COLOR] & " " & [COLOR="red"]Right(Range("L" & sat), 7)[/COLOR]
Else
Range("K" & sat) = Range("L" & sat)
End If

End Sub
kırmızı alanı inceleyiniz. Kendiniz düzenleme yapabilirsiniz.
İyi çalışmalar.
 
Son düzenleme:
sayın SEİSMİC
Sizinde ilginize ve hızlı cevanıza tşekkür ederim.
İsim 40 a eşit ve küçük olduğunda aynı aynı ismi aktarması gerekiyordu. Sayın Ergün Güler 'in kodundan da o kısmı kullandım. Çok teşekkür ederim. sorumdaki 2. alternatif içinde bir çözümünüz varsa rica edeceğim.
Saygılarımla
 
Sayın Ergün Güler
Aynen böyle istiyorum.
Çözümü bekliyorum.


Takdir edersinizki bazı isimlerin sonu;
A.Ş.
LDT.ŞTİ.
KOOP.
VAKFI
ODASI
ORTAKLIĞI
gibi ibarelerle bitiyor
son kısım önemli olduğu için kısa isim içine almam gerekiyor.
bunları bilebilecek başka bir çözüm olamaz herhalde?
saygılarımla
 
cebelitarık' Alıntı:
Sayın Ergün Güler
Aynen böyle istiyorum.
Çözümü bekliyorum.


Takdir edersinizki bazı isimlerin sonu;
A.Ş.
LDT.ŞTİ.
KOOP.
VAKFI
ODASI
ORTAKLIĞI
gibi ibarelerle bitiyor
son kısım önemli olduğu için kısa isim içine almam gerekiyor.
bunları bilebilecek başka bir çözüm olamaz herhalde?
saygılarımla
Genişletmek için tıkla ...

Selam,
5.mesaja kodları ekledim. İnceleyiniz.
yukarıdaki bahsettiğiniz soruya daha sonra cevap vemeye çalışalım. Siz de bu esnada tüm olasıkları harfi harfine tam yazınız. biz de çözümü buna göre yazalım.
eğer firma ismi sağdan baktığımızda ilk karakter ile ilk boşluk arasındakiler işinizi görüyorsa işim daha da kolaylaşır. Yani şunu demek istiyorum; - kırmızı çizgilerin olduğu yeri boşluk farz edelim.
XXXXXXXXXXXXXXXXXXXXXXXXXXX-ORTAKLIĞI
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX-A.Ş. gibi mi?






İyi çalışmalar.
 
Son düzenleme:
Sayın Ergün Güler
8. mesajınızda çok güzel bir çözüm teklif ettiniz.
Bu sağdan ilk boşluk hiç aklıma gelmemişti
Tebrik ediyorum. Son olarak bu çözümüde sunarsanız bu konuyu kapatabiliriz diye düşünüyorum.
Saygılarımla
 
cebelitarık' Alıntı:
Sayın Ergün Güler
8. mesajınızda çok güzel bir çözüm teklif ettiniz.
Bu sağdan ilk boşluk hiç aklıma gelmemişti
Tebrik ediyorum. Son olarak bu çözümüde sunarsanız bu konuyu kapatabiliriz diye düşünüyorum.
Saygılarımla
Genişletmek için tıkla ...
Selam,
elinizdeki tüm firmaların sağdan karakterlerini incelediniz mi? aynı zamanda kullandığınız ve kullanacağınız tüm ünvanları (yani sağdan olanları) harfi harfine bana gönderiniz belki alternatif başka çözümlerde bulabiliriz.

unutursam hatırlatırsınız.

Şimdilik iyi geceler.
 
Sayın Ergün Güler
Sağdan son kelimedeki tüm ünvanlar şu şekildedir.

XXXXXXXXXX ANONİM ŞİRKETİ
XXXXXXXXXX A.Ş.
XXXXXXXXXX LİMİTED ŞİRKETİ
XXXXXXXXXX LTD.ŞTİ.
XXXXXXXXXX KOOPERATİFİ
XXXXXXXXXX KOOP.
XXXXXXXXXX ODASI
XXXXXXXXXX BAŞKANLIĞI
XXXXXXXXXX DERNEĞİ
XXXXXXXXXX VAKFI
XXXXXXXXXX APARTMANI
bu gibi ibarelerle bitmektedir.
Saygılarımla
 
Son düzenleme:
Sayın Ergün Güler
Cevabınızı bekliyorum. Son mesajınızda unurtam hatırlatın demişiniz.
Saygılarımla
 
cebelitarık' Alıntı:
Sayın Ergün Güler
Cevabınızı bekliyorum. Son mesajınızda unurtam hatırlatın demişiniz.
Saygılarımla
Genişletmek için tıkla ...

Selam,

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim unvan()

unvan = Array("ANONİM ŞİRKETİ", "A.Ş.", "LİMİTED ŞİRKETİ", "LTD.ŞTİ.", _
"KOOPERATİFİ", "KOOP.", "ODASI", "BAŞKANLIĞI", "DERNEĞİ", "VAKFI", "APARTMANI")

If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("L2:L65536")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub

sat = Target.Row
say = 0

If Len(Target) <= 40 Then
Range("K" & sat) = Target

Else
    For u = LBound(unvan) To UBound(unvan)
    
    Set bul = Target.Find(What:=unvan(u), LookIn:=xlValues)
    
    If Not bul Is Nothing Then
    say = say + 1
    Range("K" & sat) = Mid(bul, 1, 39 - Len(unvan(u))) & " " & unvan(u)
    End If
    
    Next

If say = 0 Then
Range("K" & sat) = "Firmanın Ünvanı Bulunamadı. Listeyi Kontrol Ediniz."
MsgBox "Firmanın Ünvanı Bulunamadı. Listeyi Kontrol Ediniz."
End If

End If

End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst