CẦN XIN CODE VBA TÁCH CHUỖI CÓ TÔ MÀU (3 người xem)

[hamhochoi66]

Em chào anh chị em GPE,

Nhờ anh chị viết dùm code VBA để tách chuỗi có tô màu ra khỏi 1 chuỗi lớn như hình:


Xin chân thành cảm ơn các anh chị em !

 

[nguyenanhdung8111982]

Em chào anh chị em GPE,

Nhờ anh chị viết dùm code VBA để tách chuỗi có tô màu ra khỏi 1 chuỗi lớn như hình:
View attachment 296918

Xin chân thành cảm ơn các anh chị em !

Function tachmau(workCell As Range)
strLen = Len(workCell)
tachmau = ""
For i = 1 To strLen
If workCell.Characters(i, 1).Font.Color <> vbBlack Then
tachmau = tachmau & workCell.Characters(i, 1).Text
End If
Next i
End Function

 

[bebo021999]

Dùng hàm UDF nàynhé bạn

Option Explicit
Function maume(cell As Range) As String
Dim i&, st As String
For i = 1 To Len(cell)
    If cell.Characters(i, 1).Font.Color = vbRed Then
        st = IIf(st = "", "", st) & cell.Characters(i, 1).Text
    End If
Next
maume = st
Application.Caller.Font.Color = vbRed
End Function

 

[hamhochoi66]

Dạ em cảm ơn các anh!

 

[hamhochoi66]

Dùng hàm UDF nàynhé bạn

Option Explicit
Function maume(cell As Range) As String
Dim i&, st As String
For i = 1 To Len(cell)
    If cell.Characters(i, 1).Font.Color = vbRed Then
        st = IIf(st = "", "", st) & cell.Characters(i, 1).Text
    End If
Next
maume = st
Application.Caller.Font.Color = vbRed
End Function

View attachment 296921

Anh ơi, có 1 vấn đề như thế này xử lý sao anh:
Dòng 6, ban đâu chuỗi ABC, sau đó em vào ô A6 bôi đỏ thêm chữ "Văn" thì B6 cập nhật lại công thức nhưng bị dính lại không có khoảng cách. Anh giúp em với!

 

[bebo021999]

Anh ơi, có 1 vấn đề như thế này xử lý sao anh:
Dòng 6, ban đâu chuỗi ABC, sau đó em vào ô A6 bôi đỏ thêm chữ "Văn" thì B6 cập nhật lại công thức nhưng bị dính lại không có khoảng cách. Anh giúp em với!

OK, thử lại nhé: ...

Option Explicit
Function maume(cell As Range) As String
Dim i&, st As String
For i = 1 To Len(cell)
    With cell.Characters(i, 1)
        If .Font.Color = vbRed Or .Text = " " Then
            st = IIf(st = "", "", st) & .Text
        End If
    End With
Next
maume = Replace(st, "  ", " ")
Application.Caller.Font.Color = vbRed
End Function

 

[hamhochoi66]

OK, thử lại nhé: ...

Option Explicit
Function maume(cell As Range) As String
Dim i&, st As String
For i = 1 To Len(cell)
    With cell.Characters(i, 1)
        If .Font.Color = vbRed Or .Text = " " Then
            st = IIf(st = "", "", st) & .Text
        End If
    End With
Next
maume = Replace(st, "  ", " ")
Application.Caller.Font.Color = vbRed
End Function

Em thấy cái đầu tiên ổn hơn á anh, cái sau của anh nó thêm khoảng trắng trước sau như hình:



Code đầu tiên chỉ cần cập nhật tô đỏ thêm từ thì đó lấy đúng từ đó nữa là ok á anh. Phiền anh quá, em cảm ơn nhiều nhiều!

 

[bebo021999]

Cái này:

maume = Replace(st, "  ", " ")

bổ sung thêm hàm TRIM:

maume = Trim(Replace(st, "  ", " "))

Dễ mà, không biết VBA vẫn làm được.

 

[caocat]

Cái này:

maume = Replace(st, "  ", " ")

bổ sung thêm hàm TRIM:

maume = Trim(Replace(st, "  ", " "))

Dễ mà, không biết VBA vẫn làm được.

Cho em hỏi xíu. Nếu mình muốn kết quả vẫn giữ màu chữ trước khi tách thì làm như nào ạ? Em cảm ơn.