Ad Soyad Ayırma

[Ridan]

Merhaba,

Aşağıdaki kod ile ad soyad ayrımı yapılıyor. Fakat, belli bir sütun adresi (A) verilmiş.

İstediğim, imlecin bulunduğu aktif sütundaki hücreden itibaren olabilir veya sütundaki isimler aralığı seçilmiş olabilir.. ad soyadları hemen sağındaki sütunlara aktarması..

Sub ayir()

sat = 2
sut = "a"
For r = 2 To Cells(Rows.Count, sut).End(3).Row
deg1 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), " ")
deg2 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), ")")
deg3 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), "(")
son = ""
say1 = ""
say2 = ""
son = UBound(deg1)

If son = 0 Then
say1 = deg1(0)

ElseIf son = 1 Then
say1 = deg1(0)
say2 = deg1(1)
ElseIf son = 2 Then

If UBound(deg2) > 0 Or UBound(deg3) > 0 Then
say1 = deg1(0)
say2 = deg1(1) & " " & deg1(2)
Else
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2)
End If
ElseIf son = 3 Then
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2) & " " & deg1(3)

ElseIf son > 3 Then
say1 = "İkiden fazla isim var"
say2 = "İkiden fazla soy isim var"
End If

Cells(sat, "b").Value = say1
Cells(sat, "c").Value = say2
sat = sat + 1
Next

End Sub

 

[alicimri]

3. Satırdaki kodu aşağıdaki kodla değiştirin, isimlerin bulunduğu tüm sütunu seçip kodu çalıştırın

sut = Replace(Split(Selection.Address, ":")(0), "$", "")

 

[Ridan]

Olmadı, For satırında kod hata veriyor.

 

[antonio]

Yazdğınız gibi imlecinizi ad soyadların bulunduğu sütunda aktif hale getirdikten sonra kodu çalıştırabilirsiniz. (bitişik durumdaki ad soyadların, aktif olan sütunda olduğu farzedilmektedir.)

Sub ayir()
sat = 2
sut = ActiveCell.Column
For r = 2 To Cells(Rows.Count, sut).End(3).Row
deg1 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), " ")
deg2 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), ")")
deg3 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), "(")
son = ""
say1 = ""
say2 = ""
son = UBound(deg1)

If son = 0 Then
say1 = deg1(0)

ElseIf son = 1 Then
say1 = deg1(0)
say2 = deg1(1)
ElseIf son = 2 Then

If UBound(deg2) > 0 Or UBound(deg3) > 0 Then
say1 = deg1(0)
say2 = deg1(1) & " " & deg1(2)
Else
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2)
End If
ElseIf son = 3 Then
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2) & " " & deg1(3)

ElseIf son > 3 Then
say1 = "İkiden fazla isim var"
say2 = "İkiden fazla soy isim var"
End If

Cells(sat, sut + 1).Value = say1
Cells(sat, sut + 2).Value = say2
sat = sat + 1
Next

End Sub

 

[Emir Hüseyin Çoban]

. . .

Ayırdığı ad soyadı yine B - C sütunlarına mı yazacak yoksa
aktif sütunun sağına mı yazacak.

. . .

 

[Ridan]

Aktif sütunun sağına Hüseyin bey...

 

[Emir Hüseyin Çoban]

. . .

Alternatif olması için,

Sub ayir()
sat = 2
[COLOR="DarkRed"]sut = Split(Selection.Address, "$")(1)[/COLOR]
For r = 2 To Cells(Rows.Count, sut).End(3).Row
deg1 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), " ")
deg2 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), ")")
deg3 = Split(WorksheetFunction.Trim(Cells(r, sut).Value), "(")
son = ""
say1 = ""
say2 = ""
son = UBound(deg1)

If son = 0 Then
say1 = deg1(0)

ElseIf son = 1 Then
say1 = deg1(0)
say2 = deg1(1)
ElseIf son = 2 Then

If UBound(deg2) > 0 Or UBound(deg3) > 0 Then
say1 = deg1(0)
say2 = deg1(1) & " " & deg1(2)
Else
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2)
End If
ElseIf son = 3 Then
say1 = deg1(0) & " " & deg1(1)
say2 = deg1(2) & " " & deg1(3)

ElseIf son > 3 Then
say1 = "İkiden fazla isim var"
say2 = "İkiden fazla soy isim var"
End If

[COLOR="DarkRed"]Cells(sat, sut).Offset(0, 1) = say1
Cells(sat, sut).Offset(0, 2) = say2[/COLOR]
sat = sat + 1
Next

End Sub

. . .

 

[baydeniro]

teşekkürler antonio

 

[Ridan]

Çok teşekkürler antonio ve Hüseyin bey... istediğim gibi oldu.