Cắt chuỗi ký tự, tách lấy phần chữ in đậm

[Hau151978]

Vậy là mình hiểu rồi. Dùng Regexp để thay thế các ký tự ngăn cách bằng khoảng trắng rồi dò trên chuỗi này.

    Dim RE As RegExp
    Set RE = New RegExp
    RE.Global = True
    RE.Pattern = "\W"
    s = RE.Replace(s, " ")

 

[gtri]

Góp đoạn code cho xôm tụ

Public Sub Loc()
Dim Arr(), r As Long, c As Long, i, tm

tm = Timer
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\W+"
ReDim Arr(1 To Sheet1.Range("A1000000").End(xlUp).Row, 1 To 1)

For r = 1 To UBound(Arr)
Arr(r, 1) = .Replace(Sheet1.Range("A" & r), " ")
Arr(r, 1) = Split(Arr(r, 1), " ")
i = 0
For c = UBound(Arr(r, 1)) To 0 Step -1
If Sheet1.Range("A" & r).Characters(InStr(Sheet1.Range("A" & r), Arr(r, 1)(c)), Len(Arr(r, 1)(c))).Font.Bold = False Then
Arr(r, 1)(c) = ""
Else
i = i + 1
If i > 1 Then
If Arr(r, 1)(c + 1) = "" Then Arr(r, 1)(c) = Arr(r, 1)(c) & ";"
End If
End If
Next c
Arr(r, 1) = Application.Trim(Join(Arr(r, 1), " "))
Next r
End With

Sheet1.Range("E1").Resize(UBound(Arr), 1).Clear
Sheet1.Range("E1").Resize(UBound(Arr), 1) = Arr
Sheet1.Range("E1").Value = Timer - tm
End Sub

 

[doveandrose]

Vậy là mình hiểu rồi. Dùng Regexp để thay thế các ký tự ngăn cách bằng khoảng trắng rồi dò trên chuỗi này.

    Dim RE As RegExp
    Set RE = New RegExp
    RE.Global = True
    RE.Pattern = "\W"
    s = RE.Replace(s, " ")

hihi . cuối cùng bạn cũng biết chữ word trong câu hỏi ở trên chỉ là hỏi xoáy . hoàn toàn không có ý muốn bạn định nghĩa thế nào là
a single character word =))

nhưng mà câu chuyện kết thúc vầy chưa có vui . mình có tí khúc mắc muốn nhờ các bạn giải đáp . mình có chuỗi này :
my friends : hpKhuong,GiangLeLoi,Kieu-Manh
sau khi dùng hàm của bạn gtri thì nó ra là
hpKhuong GiangLeLoi Kieu Manh

nhiều khi người viết chèn kí tự đặc biệt giữa các từ in đậm là có ý đồ riêng của họ
nếu kết quả bị đổi kí tự đặc biệt đó thành " " e là làm sai lệch đi ý đồ của họ
có cách nào giữ lại kí tự ban đầu của người viết chuỗi là
hpKhuong,GiangLeLoi,Kieu-Manh
không ta ? hihi

 

[gtri]

Thử thay 2 chỗ này xem sao

.Pattern = "\W+"

thành

.Pattern = "(\W+)"

và

Arr(r, 1) = .Replace(Sheet1.Range("A" & r), " ")

thành

arr(r, 1) = Replace(Sheet1.Range("A" & r), "$1", "$1" & " ")

 

[Hau151978]

hihi . cuối cùng bạn cũng biết chữ word trong câu hỏi ở trên chỉ là hỏi xoáy . hoàn toàn không có ý muốn bạn định nghĩa thế nào là
a single character word =))

nhưng mà câu chuyện kết thúc vầy chưa có vui . mình có tí khúc mắc muốn nhờ các bạn giải đáp . mình có chuỗi này :
my friends : hpKhuong,GiangLeLoi,Kieu-Manh
sau khi dùng hàm của bạn gtri thì nó ra là
hpKhuong GiangLeLoi Kieu Manh

nhiều khi người viết chèn kí tự đặc biệt giữa các từ in đậm là có ý đồ riêng của họ
nếu kết quả bị đổi kí tự đặc biệt đó thành " " e là làm sai lệch đi ý đồ của họ
có cách nào giữ lại kí tự ban đầu của người viết chuỗi là
hpKhuong,GiangLeLoi,Kieu-Manh
không ta ? hihi

Mình cũng làm thử UDF

Option Explicit
Function TachChuoi(r As Range) As String
    Dim s$, s1$, s2$, i&, j&, n&, chk As Boolean, chk2 As Boolean
    Dim rex As RegExp
    Set rex = New RegExp
    
    s = r.Text
    With rex
        .Pattern = "\W"
        .Global = True
        s1 = .Replace(s, " ")
    End With
    
    n = Len(s)
    i = 1
    Do While i <= n
        chk2 = r.Characters(i, 1).Font.Bold
        If chk2 And (Not chk) Then s2 = s2 & "; "
        chk = chk2
        
        If Mid(s1, i, 1) = " " Then
            If chk2 Then s2 = s2 & Mid(s, i, 1)
            i = i + 1
        Else
            j = InStr(i, s1, " ")
            If j = 0 Then
                If chk2 Then s2 = s2 & Right(s, n - i + 1)
                GoTo Thoat
            End If
            If chk2 Then s2 = s2 & Mid(s, i, j - i)
            i = j
        End If
    Loop
Thoat:
    n = Len(s2)
    If n > 0 Then TachChuoi = Right(s2, n - 2)
End Function

 

[doveandrose]

cám ơn bạn gtri nhưng làm theo bạn thì bài #26 nó ra là
you,GiangLeLoi.Where

 

[gtri]

cám ơn bạn gtri nhưng làm theo bạn thì bài #26 nó ra là
you,GiangLeLoi.Where

Có lẽ trả lới sau vậy.
Đang có độ rồi.

 

[gtri]

Có lẽ trả lới sau vậy.
Đang có độ rồi.

Sửa lại code 2 dòng cũ

Public Sub Loc()
Dim arr() As Variant, r As Long, c As Long, i, tm

tm = Timer
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "([A-Za-z\s]+)([^A-Za-z\s])"  '<--Sửa chỗ này để giữ lại dấu "_"
ReDim arr(1 To Sheet1.Range("A1000000").End(xlUp).Row, 1 To 1)

For r = 1 To UBound(arr)
arr(r, 1) = .Replace(Sheet1.Range("A" & r), "$1" & " " & "$2" & " ")   '<--Sửa lại chỗ này
arr(r, 1) = Split(arr(r, 1), " ")
i = 0

For c = UBound(arr(r, 1)) To 0 Step -1
If Sheet1.Range("A" & r).Characters(InStr(Sheet1.Range("A" & r), arr(r, 1)(c)), 1).Font.Bold = False Then
arr(r, 1)(c) = ""
Else
i = i + 1
If i > 1 Then
If arr(r, 1)(c + 1) = "" Then arr(r, 1)(c) = arr(r, 1)(c) & ";"
End If
End If
Next c

arr(r, 1) = Application.Trim(Join(arr(r, 1), " "))
Next r
End With

Sheet1.Range("E1").Resize(UBound(arr), 1).Clear
Sheet1.Range("E1").Resize(UBound(arr), 1) = arr
Sheet1.Range("E1").Value = Timer - tm
End Sub

---
Sub Loc() ở trên kết quả bị thừa một vài khoảng trắng, UDF của bạn Hau151978 chính xác hơn