Kelime Ayırma Formülü yada Kodu

[meslek5]

Merhaba, Aşağıda örnek olarak verdiğim bitişik kelimenin "_" (alttire) kısımları benim belirlediğim ayrılma yerleridir. Bu ayrılma yerlerinin öncesi ve sonrasını kelime olarak ayırabileceğimiz makro kodu veya formül var mı?

ÖRNEK-1 A1 hücresindeki Asya Damla KIZILIRMAK_Perşembe = B1 hücresine Asya Damla KIZILIRMAK, C1 hücresine Perşembe yazılarak ayrılacak
ÖRNEK-2 A1 hücresindeki Asya Damla KIZILIRMAK_Fuat DEMİR_Perşembe = B1 hücresine Asya Damla KIZILIRMAK, C1 hücresine Fuat DEMİR, D1 hücresine Perşembe yazılarak ayrılacak

Kelimeler bazen ikili bazen dörtlü bile olabiliyor bunun için yazılacak en iyi formül nedir? yada makro

 

[Muzaffer Ali]

Merhaba.
İyi bayramlar.
Aşağıdaki kod istediğinizi gerçekleştiriyor.

Sub test()
    Dim Parca() As String
    Dim Bak As Long
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Parca = Split(Cells(Bak, "A"), "_")
        Range("B" & Bak & ":" & Cells(Bak, 2 + UBound(Parca)).Address) = Parca
    Next
End Sub

 

[meslek5]

Merhaba.
İyi bayramlar.
Aşağıdaki kod istediğinizi gerçekleştiriyor.

Sub test()
    Dim Parca() As String
    Dim Bak As Long
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Parca = Split(Cells(Bak, "A"), "_")
        Range("B" & Bak & ":" & Cells(Bak, 2 + UBound(Parca)).Address) = Parca
    Next
End Sub

Hocam teşekkür ederim. Peki bunu formül ile yapabilir miyiz? çünkü bitişik kelimeler değişik sütun ve satırlarda yer alıyor.

 

[numan şamil]

Kodla olur derseniz
denermisiniz

Sub Numan()
Dim i As Long
Application.ScreenUpdating = False
Range("B1:D" & Rows.Count).ClearContents
For i = 1 To Cells(Rows.Count, 1).End(3).Row
On Error Resume Next
Cells(i, 2) = Split(Cells(i, 1), "_")(0)
Cells(i, 3) = Split(Cells(i, 1), "_")(1)
Cells(i, 4) = Split(Cells(i, 1), "_")(2)
Next i
Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Aşağıdaki kodu bir modüle kopyalayın.

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    Parcala = Parca(Sira - 1)
End Function

Kullanımı, herhangi bir hücreye aşağıdaki gibi formül yazarak kullanabilirsiniz.
=Parcala(A2;1) 1. parçayı döndürür.
=Parcala(A2;2) 2. parçayı döndürür.
=Parcala(A2;5) 5. parçayı döndürür.

 

[meslek5]

Aşağıdaki kodu bir modüle kopyalayın.

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    Parcala = Parca(Sira - 1)
End Function

Kullanımı, herhangi bir hücreye aşağıdaki gibi formül yazarak kullanabilirsiniz.
=Parcala(A2;1) 1. parçayı döndürür.
=Parcala(A2;2) 2. parçayı döndürür.
=Parcala(A2;5) 5. parçayı döndürür.

çok teşekkür ederim hocam oldu

 

[meslek5]

Kodla olur derseniz
denermisiniz

Sub Numan()
Dim i As Long
Application.ScreenUpdating = False
Range("B1:D" & Rows.Count).ClearContents
For i = 1 To Cells(Rows.Count, 1).End(3).Row
On Error Resume Next
Cells(i, 2) = Split(Cells(i, 1), "_")(0)
Cells(i, 3) = Split(Cells(i, 1), "_")(1)
Cells(i, 4) = Split(Cells(i, 1), "_")(2)
Next i
Application.ScreenUpdating = True
End Sub

teşekkür ederim hocam

 

[S.Yiğit]

Formül biraz sıkıntıda olsa aşağıdaki gibi deneyebilirsiniz, Veri sekmesi altında Metinleri sütunlara dönüştür özelliğini kullanmanızı tavsiye ederim.

Tek tire olanlarda tireden öncekini almak için;

SOLDAN(A1;MBUL("_";A1;1)-1)

İki Tire arasını almak için; (Birinci ve ikinci tire arasını)

=PARÇAAL(A2;MBUL("_";A2;1)+1;BUL("_";YERİNEKOY(A2;"_";1;1))-MBUL("_";A2;1)-1)

ikinci tireden sonrasını almak için

=PARÇAAL(A2;BUL("_";YERİNEKOY(A2;"_";1;1))+1;MBUL("_";A2;1))

 

[meslek5]

Aşağıdaki kodu bir modüle kopyalayın.

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    Parcala = Parca(Sira - 1)
End Function

Kullanımı, herhangi bir hücreye aşağıdaki gibi formül yazarak kullanabilirsiniz.
=Parcala(A2;1) 1. parçayı döndürür.
=Parcala(A2;2) 2. parçayı döndürür.
=Parcala(A2;5) 5. parçayı döndürür.

Hocam 3 bitişik kelime olunca ve 4. parça olmayınca DEĞER olarak görünüyor bunu nasıl engelleyebilirim

 

[Muzaffer Ali]

4. parça yoksa, hata verecek ve sizi uyaracak. Zaten olması gereken de bu.
Ama isterseniz mesaj verecek şekilde değiştirilebilir.

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    If UBound(Parca) + 1 < Sira Then MsgBox "Metni " & Sira & " parçaya bölemezsiniz."
    Parcala = Parca(Sira - 1)
End Function

 

[meslek5]

4. parça yoksa, hata verecek ve sizi uyaracak. Zaten olması gereken de bu.
Ama isterseniz mesaj verecek şekilde değiştirilebilir.

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    If UBound(Parca) + 1 < Sira Then MsgBox "Metni " & Sira & " parçaya bölemezsiniz."
    Parcala = Parca(Sira - 1)
End Function

mesaj yerine "değer" yazan yerleri boş gösterebilir miyiz? mesela 3 bitişik kelimenin 4. parçası yoksa veya 2 bitişik kelimenin 3. parçası yoksa hücrede değer yerine boş göstersin olur mu?

 

[Muzaffer Ali]

Function Parcala(Hucre As Range, Sira As Integer)
    Dim Parca() As String
    Dim Bak As Long
    Parca = Split(Hucre, "_")
    If UBound(Parca) + 1 < Sira Then
        Parcala = ""
    Else
        Parcala = Parca(Sira - 1)
    End If
End Function