Hücredeki kelimeleri ayırmak

[baydeniro]

Merhaba arkadaşlar. D sütununda yazı ile dolu hücrelerdeki kelimeleri H sütununda kelime kelime ayrılması makro kodu yardımıyla mümkün olur mu !

örneğin D1 hücresinde "Domates fiyatları yüzde beş arttı" yazısını
Domates
fiyatları
yüzde
beş
arttı

şeklinde ayırtabilir miyiz. D2 ve aşağıya doğru dolu hücreleri kelimelere ayrılması mümkün mü ?

 

[Korhan Ayhan]

Aşağıdaki kullanıcı tanımlı fonksiyonu deneyebilirsiniz.

=KPARÇAAL(Hücre;Kaçıncı_Kelime)

=KPARÇAAL(A1;1)

Function KPARÇAAL(Veri As Range, Kaçıncı_Kelime As Integer)
    KPARÇAAL = Split(Veri.Value, " ")(Kaçıncı_Kelime - 1)
End Function

 

[baydeniro]

Çok teşekkür ediyorum sayın Korhan Ayhan, çok iyi oldu. Sağlıcakla kalın.

 

[baydeniro]

Korhan üstadım, bu çözüm çok işime yaradı, tekrar teşekkür ederim. Acaba şöyle bir çözüm olma olasılığı var mı ? A1 hücresindeki kelimeleri (boşlukları kriter alarak) B sütununa dağıtması formülleme dışında sadece kod ile tek hamlede mümkün olur mu ?

 

[Korhan Ayhan]

Aşağıdaki kodu kullanabilirsiniz.

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer
    
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(Veri.Value, " ")
        For X = 0 To UBound(Kelime)
            Cells(Veri.Row, X + 2) = Kelime(X)
        Next
    Next
    
    Cells.EntireColumn.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[baydeniro]

Sayın Korhan Ayhan çok çok teşekkür ediyorum. Allah razı olsun. Harika bir kod. Bu kod fazlasıyla işimi görecek. Kod yapısının nasıl değiştiğini gözlemlemek açısından sadece minik bir ricam olacak : ayrılan kelimeleri B sütununda yukarıdan aşağıya doğru yazdırmak isteseydik kod yapısında nereyi değiştirmek lazım ?

 

[Korhan Ayhan]

Aşağıdaki kodu kullanabilirsiniz.

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer, Satir As Long
    
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
    Satir = 1
    
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(Veri.Value, " ")
        For X = 0 To UBound(Kelime)
            Cells(Satir, 2) = Kelime(X)
            Satir = Satir + 1
        Next
    Next
    
    Range("B:B").EntireColumn.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[baydeniro]

Korahn üstadım, mükemmel x mükemmel oldu. Aynı konuda 3 ayrı alternatif oldu ki. kör istedi bir göz, Korhan üstad verdi 3 göz gibi bir şey oldu. Çok teşekkür ediyorum. Sağlıcakla kalın.

 

[Tevfik_Kursun]

Ben de teşekkür ederim
Saygılarımla

 

[HACI46]

Aşağıdaki kodu kullanabilirsiniz.

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer
   
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(Veri.Value, " ")
        For X = 0 To UBound(Kelime)
            Cells(Veri.Row, X + 2) = Kelime(X)
        Next
    Next
   
    Cells.EntireColumn.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey merhaba
Burada A1:A3 hücrelerindeki verilerin tamamını Değilde, Son 2 boşluktan sonrasın, Yani Sağdan 1. ve 2. Boşluklardan Ayırmak mümkün mü ?
Selamlar iyi akşamlar.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer
   
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(StrReverse(Veri.Value), " ")
        For X = 0 To WorksheetFunction.Min(1, UBound(Kelime))
            If IsNumeric(StrReverse(Kelime(X))) Then
                Cells(Veri.Row, X + 2) = CDbl(StrReverse(Kelime(X)))
            Else
                Cells(Veri.Row, X + 2) = StrReverse(Kelime(X))
            End If
        Next
    Next
   
    Cells.EntireColumn.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[HACI46]

Deneyiniz.

Option Explicit

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer
  
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
  
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(StrReverse(Veri.Value), " ")
        For X = 0 To WorksheetFunction.Min(1, UBound(Kelime))
            If IsNumeric(StrReverse(Kelime(X))) Then
                Cells(Veri.Row, X + 2) = CDbl(StrReverse(Kelime(X)))
            Else
                Cells(Veri.Row, X + 2) = StrReverse(Kelime(X))
            End If
        Next
    Next
  
    Cells.EntireColumn.AutoFit
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Ellerinize sağlık Korhan bey çok güzel oldu, Küçük bir sorun var ( Ayran 22,00 44,00 ) bir tek bunu bölmüyor, A sütununda yerini de değiştirip denedim ama aynı, oysa aynı karakterlerde ( Lavas 13,00 13,00 ) bu var bunu bölüyor.

 

[Korhan Ayhan]

Ayran 22,00 44,00 ifadesinde boşluk gibi görünen karakterler farklı bir karakter olabilir. Kontrol ediniz.

 

[HACI46]

Ayran 22,00 44,00 ifadesinde boşluk gibi görünen karakterler farklı bir karakter olabilir. Kontrol ediniz.

Aynı ifadeyi silerek elle de yazıp denedim ama yine aynı, hücre yapısında bir sıkıntı yok, çünkü onun yerine ( Lavas 13,00 13,00 ) ı yazıyorum onu bölüyor.

 

[Korhan Ayhan]

Dosyanızı paylaşırsanız sorunu inceleme şansımız olur.

 

[HACI46]

Aynı ifadeyi silerek elle de yazıp denedim ama yine aynı, hücre yapısında bir sıkıntı yok, çünkü onun yerine ( Lavas 13,00 13,00 ) ı yazıyorum onu bölüyor.

Aynı ifadeyi silerek elle de yazıp denedim ama yine aynı, hücre yapısında bir sıkıntı yok, çünkü onun yerine ( Lavas 13,00 13,00 ) ı yazıyorum onu bölüyor.

Korhan bey birde yeni altın üyelerin DVD yi indirme link ini gezindim ama göremedim, hangi link ten indirebilirim.
Selamlar, Sağlıklı günler dileği ile hayırlı geceler.

 

[Korhan Ayhan]

Sorun çözüldü mü anlamadım...

DVD ile ilgili olarak @Hüseyin beye danışınız.

 

[HACI46]

Korhan bey kod çalışması TEST.xlsm olarak yükledim.

 

[Korhan Ayhan]

Siz şöyle yapın;

A1 hücresini seçin ve F2 tuşuna basın.
Sonra hücrenin sonundaki FAZLA boşlukları temizleyin.

Sonra kodu tekrar deneyin.

 

[Korhan Ayhan]

Ek olarak bu şekilde gereksiz karakter (boşluk) içeren verileriniz varsa kodu aşağıdaki gibi revize etmek daha uygun olacaktır.

Option Explicit

Sub KELİMELERİ_AYIR()
    Dim Veri As Range, Son As Long, Kelime As Variant, X As Integer
   
    Range(Cells(1, 2), Cells(Rows.Count, Columns.Count)).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For Each Veri In Range("A1:A" & Son)
        Kelime = Split(StrReverse(Application.Trim(Veri.Value)), " ")
        For X = 0 To WorksheetFunction.Min(1, UBound(Kelime))
            If IsNumeric(StrReverse(Kelime(X))) Then
                Cells(Veri.Row, X + 2) = CDbl(StrReverse(Kelime(X)))
            Else
                Cells(Veri.Row, X + 2) = StrReverse(Kelime(X))
            End If
        Next
    Next
   
    Cells.EntireColumn.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub