- Katılım
- 21 Haziran 2021
- Mesajlar
- 64
- Excel Vers. ve Dili
- türkçe
- Altın Üyelik Bitiş Tarihi
- 20-07-2023
Merhaba. Örnek dosyada ki ardışık gelen isimleri nasıl teke düşürebilirim
Ekli dosyalar
-
25.5 KB Görüntüleme: 9
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub tekle()
son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
veri = Split(Cells(i, "A"), " ")
ad = ""
For j = 1 To UBound(veri)
If veri(j) = veri(0) Then
For k = 0 To j - 1
If ad = "" Then
ad = veri(k)
Else
ad = ad & " " & veri(k)
End If
Next
Cells(i, "B") = ad
k = UBound(veri)
j = UBound(veri)
End If
Next
If Cells(i, "B") = "" Then Cells(i, "B") = Cells(i, "A")
Next
End Sub
İŞE YARADI .Emeğinize sağlıkFormülle yapmak isterseniz de ekli dosyayı kullanırsınız.
Harika oldu teşekkürler.Aşağıdaki makroyu dener misiniz?
PHP:Sub tekle() son = Cells(Rows.Count, "A").End(3).Row For i = 2 To son veri = Split(Cells(i, "A"), " ") ad = "" For j = 1 To UBound(veri) If veri(j) = veri(0) Then For k = 0 To j - 1 If ad = "" Then ad = veri(k) Else ad = ad & " " & veri(k) End If Next Cells(i, "B") = ad k = UBound(veri) j = UBound(veri) End If Next If Cells(i, "B") = "" Then Cells(i, "B") = Cells(i, "A") Next End Sub
Option Explicit
Function UNIQUE_WORDS(My_Range As Range)
Application.Volatile True
With VBA.CreateObject("VBScript.RegExp")
.Pattern = "^(.+)\s*\1$"
.Global = True
.MultiLine = True
UNIQUE_WORDS = .Replace(My_Range.Value, "$1")
End With
End Function