Hỗ trợ hàm UDF tách chữ tô màu

Liên hệ QC
Tình nghĩa giang hồ

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu
Tham gia
29/9/20
Bài viết
330
Được thích
429
Chào anh em GPE, mình có bài tập tách chữ tô màu nhờ anh em hỗ trợ giúp.
Nội dung chỉ đơn giản chỗ nào có màu đỏ thì mình tách sang cột mới.
Nhờ anh em hỗ trợ gúp, cảm ơn anh em GPE.
 

File đính kèm

  • tách chữ tô màu đỏ.jpg
    tách chữ tô màu đỏ.jpg
    74.3 KB · Đọc: 45
  • tách chữ màu đỏ.xlsb
    8.4 KB · Đọc: 20
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Upvote 0
huuthang_bd đã viết:
Bài tập này do thầy Sếp giao đúng không bạn?
Nhấp chuột vào đây để mở rộng...
Bài tập của bạn bè cafe thôi bạn, một nhạc sĩ...........một câu hỏi vu vơ, nhưng là bạn bè thì mình tìm hiểu và giúp bạn đó.
(Chỉ cần gọi nhau là anh em thì khó khăn cỡ nào cũng giúp cơ mà.......)
 
Upvote 0
UDF không thể tạo nên cái gì trên bảng tính cả. Đó là luật bảo vệ bảng tính của Microsoft.
Cách gần như duy nhất để đi vòng qua luật này là tạm thời dùng một công cụ khác giật lại điều khiển (controls) từ UDF. Công cụ ấy là Class Module.

Code làm việc này khá rắc rối.

Trước khi bắt đâu viết cái code Class Module thì phải hiểu rõ tại sao Microsoft ra cái luật "bảo vệ" này:
1. Hàm không thể lấn ngoài phạm vi ô chứa nó. Lấn tùm lum hư hết dữ liệu những nơi khác.
2. Khi tham số hàm thay đổi, nó phải gỡ những gì mà nó tạo ra trước đó? Điều này gần như không thể thực hiện. Bởi vì nếu nhiều hàm tạo tùm lum thì nó biết gỡ phần của nó ra sao?
 
Upvote 0
Tình nghĩa giang hồ đã viết:
Chào anh em GPE, mình có bài tập tách chữ tô màu nhờ anh em hỗ trợ giúp.
Nội dung chỉ đơn giản chỗ nào có màu đỏ thì mình tách sang cột mới.
Nhờ anh em hỗ trợ gúp, cảm ơn anh em GPE.
Nhấp chuột vào đây để mở rộng...
Dùng hàm tự tạo
Mã: 
Function KyTuDo(ByVal rng As Range)
  Dim txt$, tmp$, N&, j&, fj&
  txt = rng.Value
  N = Len(txt)
  For j = 1 To N
    If rng.Characters(j, 1).Font.ColorIndex = 3 Then
      If fj = 0 Then fj = j
    End If
    If fj > 0 Then
      If rng.Characters(j, 1).Font.ColorIndex <> 3 Or j = N Then
        If j = N Then j = N + 1
        tmp = tmp & "; " & Mid(txt, fj, j - fj)
        fj = 0
      End If
    End If
  Next j
  KyTuDo = Mid(tmp, 3)
End Function
Công thứ trong sheet
Mã: 
B2 =KyTuDo(A2)
Copy xuống
 
Upvote 0
HieuCD đã viết:
Dùng hàm tự tạo
Mã: 
Function KyTuDo(ByVal rng As Range)
  Dim txt$, tmp$, N&, j&, fj&
  txt = rng.Value
  N = Len(txt)
  For j = 1 To N
    If rng.Characters(j, 1).Font.ColorIndex = 3 Then
      If fj = 0 Then fj = j
    End If
    If fj > 0 Then
      If rng.Characters(j, 1).Font.ColorIndex <> 3 Or j = N Then
        If j = N Then j = N + 1
        tmp = tmp & "; " & Mid(txt, fj, j - fj)
        fj = 0
      End If
    End If
  Next j
  KyTuDo = Mid(tmp, 3)
End Function
Công thứ trong sheet
Mã: 
B2 =KyTuDo(A2)
Copy xuống
Nhấp chuột vào đây để mở rộng...
Hàm này sử dụng ngon lành cành đào. Xin đa tạ người anh em Hieu CD nhé.
 
Upvote 0
HieuCD đã viết:
Dùng hàm tự tạo
Mã: 
Function KyTuDo(ByVal rng As Range)
  Dim txt$, tmp$, N&, j&, fj&
  txt = rng.Value
  N = Len(txt)
  For j = 1 To N
    If rng.Characters(j, 1).Font.ColorIndex = 3 Then
      If fj = 0 Then fj = j
    End If
    If fj > 0 Then
      If rng.Characters(j, 1).Font.ColorIndex <> 3 Or j = N Then
        If j = N Then j = N + 1
        tmp = tmp & "; " & Mid(txt, fj, j - fj)
        fj = 0
      End If
    End If
  Next j
  KyTuDo = Mid(tmp, 3)
End Function
Công thứ trong sheet
Mã: 
B2 =KyTuDo(A2)
Copy xuống
Nhấp chuột vào đây để mở rộng...
Đối với bài này tách chữ màu đỏ thì code này quá ok. Nhưng cho mình hỏi thêm bác HieuCD. Giả sử trong đoạn văn của mình không chỉ một màu đỏ, mà là * đỏ, cam, vàng, lục, lam, chàm, tím* thì mình sửa code lại như thế nào bác Hieu CD. Nói nôm na: là màu đen là màu trung tâm, khác với màu đen thì mình lấy ra cột mới. Cái này là mình hỏi thêm.
 
Upvote 0
Tình nghĩa giang hồ đã viết:
Đối với bài này tách chữ màu đỏ thì code này quá ok. Nhưng cho mình hỏi thêm bác HieuCD. Giả sử trong đoạn văn của mình không chỉ một màu đỏ, mà là * đỏ, cam, vàng, lục, lam, chàm, tím* thì mình sửa code lại như thế nào bác Hieu CD. Nói nôm na: là màu đen là màu trung tâm, khác với màu đen thì mình lấy ra cột mới. Cái này là mình hỏi thêm.
Nhấp chuột vào đây để mở rộng...
Thử các tùy chọn theo hướng dẫn trong hàm "KyTuMau"
Mã: 
Function KyTuMau(ByVal rng As Range, Optional ByVal ColorID As Long = -1)
  Dim absID&, jColor&, bPos As Boolean, txt$, tmp$, N&, j&, fj&
' Lay cac ky tu co Ma Mau "ColorID" cua chuoi gia tri "rng"
' "- ColorID" Lay cac ky tu co Ma Mau "Khác" "ColorID"
' "ColorID" mac dinh = -1: lay cac ký tu khong phai Mau "Den" hoac "Automatic"
' KyTuMau(A2,3) lay cac ky tu co Ma Mau = 3 cua chuoi gia tri o "A2"
' KyTuMau(A2) lay cac ky tu co Mau khac mau "Den"
  Application.Volatile
  absID = Abs(ColorID)
  bPos = (ColorID > 0)
  txt = rng.Value
  N = Len(txt)
  For j = 1 To N
    jColor = rng.Characters(j, 1).Font.ColorInDex
    If jColor = -4105 Then jColor = 1
    If (jColor = absID) = bPos Then
      If fj = 0 Then fj = j
    End If
    If fj > 0 Then
      If (jColor <> absID) = bPos Or j = N Then
        If j = N Then j = N + 1
        tmp = tmp & "; " & Mid(txt, fj, j - fj)
        fj = 0
      End If
    End If
  Next j
  KyTuMau = Mid(tmp, 3)
End Function
Khuyến mãi thêm hàm "ColorID" xác định "Mã màu"
Mã: 
Function ColorID(ByVal rng As Range, Optional ByVal Order_Number As Long = 1) As Long
' Lay Ma Màu ky tu thu "Order_Number" cua chuoi gia tri "rng"
' =ColorID(A2,4) lay Ma Màu ky tu thu "4" cua chuoi gia tri o "A2"
' "Order_Number" mac dinh = 1
' =ColorID(A2) lay Ma Màu ky tu thu "1" cua o "A2"
  Application.Volatile
  ColorID = rng.Characters(Order_Number, 1).Font.ColorInDex
End Function
Có thể có vài trường hợp đặc biệt hơi lạ do giới hạn của ".Font.ColorInDex"
 
Upvote 0
HieuCD đã viết:
Thử các tùy chọn theo hướng dẫn trong hàm "KyTuMau"
Mã: 
Function KyTuMau(ByVal rng As Range, Optional ByVal ColorID As Long = -1)
  Dim absID&, jColor&, bPos As Boolean, txt$, tmp$, N&, j&, fj&
' Lay cac ky tu co Ma Mau "ColorID" cua chuoi gia tri "rng"
' "- ColorID" Lay cac ky tu co Ma Mau "Khác" "ColorID"
' "ColorID" mac dinh = -1: lay cac ký tu khong phai Mau "Den" hoac "Automatic"
' KyTuMau(A2,3) lay cac ky tu co Ma Mau = 3 cua chuoi gia tri o "A2"
' KyTuMau(A2) lay cac ky tu co Mau khac mau "Den"
  Application.Volatile
  absID = Abs(ColorID)
  bPos = (ColorID > 0)
  txt = rng.Value
  N = Len(txt)
  For j = 1 To N
    jColor = rng.Characters(j, 1).Font.ColorInDex
    If jColor = -4105 Then jColor = 1
    If (jColor = absID) = bPos Then
      If fj = 0 Then fj = j
    End If
    If fj > 0 Then
      If (jColor <> absID) = bPos Or j = N Then
        If j = N Then j = N + 1
        tmp = tmp & "; " & Mid(txt, fj, j - fj)
        fj = 0
      End If
    End If
  Next j
  KyTuMau = Mid(tmp, 3)
End Function
Khuyến mãi thêm hàm "ColorID" xác định "Mã màu"
Mã: 
Function ColorID(ByVal rng As Range, Optional ByVal Order_Number As Long = 1) As Long
' Lay Ma Màu ky tu thu "Order_Number" cua chuoi gia tri "rng"
' =ColorID(A2,4) lay Ma Màu ky tu thu "4" cua chuoi gia tri o "A2"
' "Order_Number" mac dinh = 1
' =ColorID(A2) lay Ma Màu ky tu thu "1" cua o "A2"
  Application.Volatile
  ColorID = rng.Characters(Order_Number, 1).Font.ColorInDex
End Function
Có thể có vài trường hợp đặc biệt hơi lạ do giới hạn của ".Font.ColorInDex"
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác HieuCD nhé. Bác thật có Tâm.
 
Upvote 0
Bạn thử xem thế này ổn không bạn:

JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$, l&
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  For i = 1 To UBound(ss)
    l = CLng("&H" & VBA.Left(ss(i), 6))
    If l <> DiffColor Then
      s = s & IIf(s <> vbNullString, "; ", vbNullString) & VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
    End If
  Next
  getValueDrew = s
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn copy lại bản này cho chính xác yêu cầu:
JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  For i = 1 To UBound(ss)
    If CLng("&H" & VBA.Left(ss(i), 6)) <> DiffColor Then
      s = s & IIf(s <> vbNullString, "; ", vbNullString) & VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
    End If
  Next
  getValueDrew = s
End Function
 
Upvote 0
HeSanbi đã viết:
Bạn copy lại bản này cho chính xác yêu cầu:
JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  For i = 1 To UBound(ss)
    If CLng("&H" & VBA.Left(ss(i), 6)) <> DiffColor Then
      s = s & IIf(s <> vbNullString, "; ", vbNullString) & VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
    End If
  Next
  getValueDrew = s
End Function
Nhấp chuột vào đây để mở rộng...
Kết quả nè bác, có vài chỗ chưa ổn lắm. Dù sao cũng cám ơn bác nhiều.
 

File đính kèm

  • tách chữ màu đỏ.xlsb
    18.6 KB · Đọc: 5
  • CODE MỚI.jpg
    CODE MỚI.jpg
    82.2 KB · Đọc: 25
Upvote 0
Tình nghĩa giang hồ đã viết:
Kết quả nè bác, có vài chỗ chưa ổn lắm. Dù sao cũng cám ơn bác nhiều.
Nhấp chuột vào đây để mở rộng...

Bạn sửa một chút:

JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$, a$
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  If UBound(ss) > 0 Then
    For i = 1 To UBound(ss)
      If CLng("&H" & VBA.Left(ss(i), 6)) <> DiffColor Then
        a = VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
        Select Case a
        Case " ", vbNewLine, vbTab, vbCr, vbLf
        Case Else: s = s & IIf(s <> vbNullString, "; ", vbNullString) & a
        End Select
      End If
    Next
  Else
    If target(1, 1).Font.Color <> DiffColor Then
      s = target(1, 1).Value
    End If
  End If
  getValueDrew = s
End Function
 
Upvote 0
HeSanbi đã viết:

Bạn sửa một chút:

JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$, a$
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  If UBound(ss) > 0 Then
    For i = 1 To UBound(ss)
      If CLng("&H" & VBA.Left(ss(i), 6)) <> DiffColor Then
        a = VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
        Select Case a
        Case " ", vbNewLine, vbTab, vbCr, vbLf
        Case Else: s = s & IIf(s <> vbNullString, "; ", vbNullString) & a
        End Select
      End If
    Next
  Else
    If target(1, 1).Font.Color <> DiffColor Then
      s = target(1, 1).Value
    End If
  End If
  getValueDrew = s
End Function
Nhấp chuột vào đây để mở rộng...
Code mới đã ngon lành cành đào rồi bác HeSanbi
Bài đã được tự động gộp:

HeSanbi đã viết:

Bạn sửa một chút:

JavaScript: 
Function getValueDrew(ByVal target As Range, Optional DiffColor = 0) As String
  Dim i&, ss, s$, a$
  ss = VBA.Split(target(1, 1).Value(11), "html:Color=""#", , 1)
  If UBound(ss) > 0 Then
    For i = 1 To UBound(ss)
      If CLng("&H" & VBA.Left(ss(i), 6)) <> DiffColor Then
        a = VBA.Split(VBA.Mid(ss(i), 9), "</Font>", , 1)(0)
        Select Case a
        Case " ", vbNewLine, vbTab, vbCr, vbLf
        Case Else: s = s & IIf(s <> vbNullString, "; ", vbNullString) & a
        End Select
      End If
    Next
  Else
    If target(1, 1).Font.Color <> DiffColor Then
      s = target(1, 1).Value
    End If
  End If
  getValueDrew = s
End Function
Nhấp chuột vào đây để mở rộng...
Bác là tác giả TÌM KIẾM VÀ TÔ MÀU CHUỖI TÌM ĐƯỢC phải không? Bài viết đó khá hay, khá nhiều ứng dụng cho công việc. Nay hân hạnh được gặp gỡ, đúng là đáng vui đáng mừng.
 

File đính kèm

  • code mới 2.jpg
    code mới 2.jpg
    97.9 KB · Đọc: 15
Lần chỉnh sửa cuối:
Upvote 0
Tình nghĩa giang hồ đã viết:
Code mới đã ngon lành cành đào rồi bác HeSanbi
Bài đã được tự động gộp:


Bác là tác giả TÌM KIẾM VÀ TÔ MÀU CHUỖI TÌM ĐƯỢC phải không? Bài viết đó khá hay, khá nhiều ứng dụng cho công việc. Nay hân hạnh được gặp gỡ, đúng là đáng vui đáng mừng.
Nhấp chuột vào đây để mở rộng...
Phiên bản Pro dành cho bạn:
Bạn có thể chọn tùy chọn RevDiff là True/False
Tức là đặt màu đen, thì tìm tất cả khác màu đen / hoặc chính màu đen
 

File đính kèm

  • tách chữ màu đỏ.xlsb
    26.7 KB · Đọc: 22
Lần chỉnh sửa cuối:
Upvote 0
Có trường hơp ngược lại được không anh @HeSanbi , tức là =HAM(Range,TXT,optional Color) thì trong Range sẽ tìm ra đoạn TXT và tô Color(mặc định đỏ).
 
Upvote 0
htin1997 đã viết:
Có trường hơp ngược lại được không anh @HeSanbi , tức là =HAM(Range,TXT,optional Color) thì trong Range sẽ tìm ra đoạn TXT và tô Color(mặc định đỏ).
Nhấp chuột vào đây để mở rộng...
Bài viết nằm ở đây sẽ giúp bạn đạt được mong muốn
www.giaiphapexcel.com

FindFormat - Hàm tìm kiếm định dạng chuỗi trong ô, chú thích và hình dạng excel

TÌM KIẾM, ĐỊNH DẠNG PHÔNG VÀ TÔ MÀU CHUỖI TRONG Ô, CHÚ THÍCH VÀ HÌNH DẠNG EXCEL với Hàm FindFormat Trong Excel khi ta muốn tô đậm, hoặc đổi màu một đoạn văn bản trong ô nào đó, ta phải thao tác tay, nhưng nếu rất nhiều ô cần thực hiện như vậy thì sẽ mất rất nhiều thời gian, chính...
www.giaiphapexcel.com www.giaiphapexcel.com
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Thích
Trả lời
4
Đọc
108
HeSanbi
HeSanbi
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
10
Đọc
425
Duy Tùng 9x
Duy Tùng 9x
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
5
Đọc
122
nguyenhuong91
N
X
  • Question
Xin trợ giúp code để lọc dữ liệu
Trả lời
3
Đọc
50
Hoàng Tuấn 868
H
B
  • Question
Xin hướng dẫn tách 1 vùng dữ liệu sang thành nhiều sheet
Trả lời
3
Đọc
85
SA_DQ
SA_DQ
L
Dùng vlookup đưa kết quả không được
Trả lời
6
Đọc
56
CHAOQUAY
C
OverAC
Gặp gỡ giao lưu tại Hà Nội, chiều ngày 10/11/2025. cùng Ptm0412, OverAC và các anh chị thân thiết.
    • Thích
    • Yêu thích
Trả lời
5
Đọc
153
PhanTuHuong
PhanTuHuong
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
194
Đọc
10K
HeSanbi
HeSanbi
Hai Lúa Miền Tây
Nhập liệu, truy vấn dữ liệu qua Internet = VB.Net
    • Thích
2
Trả lời
26
Đọc
10K
phamduyhoang2907
P
P
Connection string cho SQL Express 2005
Trả lời
7
Đọc
7K
phamduyhoang2907
P
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
4
Đọc
182
CHAOQUAY
C
Quyen182
  • Question
Xin giúp code VBA để chèn ảnh có sẵn trong Excel vào phần comment
Trả lời
0
Đọc
69
Quyen182
Quyen182
Toanke063
  • Question
Xin hỏi code vba chuyển 1 file pdf bất kì thành ảnh
Trả lời
7
Đọc
173
cantl
C
HeSanbi
  • Đã giải quyết
ZaloExcel v2.92: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
55
Đọc
14K
HeSanbi
HeSanbi
Bebooby
Tách mã sản phẩm trong chuỗi thông tin
Trả lời
2
Đọc
74
NT Ngoc Yen
N
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
8
Đọc
170
thlpro
thlpro
S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
78
sakurasumo
S
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
660
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
143
ptm0412
ptm0412
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
253
CNKyNguyen
CNKyNguyen
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom