Tìm kiếm, định dạng phông và tô màu chuỗi với hàm UDF Excel

Liên hệ QC

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
Tham gia
24/2/13
Bài viết
2,382
Được thích
3,532
Giới tính
Nam
TÌM KIẾM, ĐỊNH DẠNG PHÔNG VÀ TÔ MÀU CHUỖI TÌM ĐƯỢC
với Hàm S_Find và S_Find2

S_Find - Tìm kiếm và định dạng trực tiếp tại ô chứa giá trị
S_Find2 - Mang giá trị đến một vùng mới sau đó tìm kiếm và định dạng
(Vì Excel không cho phép định dạng phông thành phần chuỗi tại một ô chứa công thức nên phải mang giá trị đến ô khác.)

Hướng dẫn sử dụng hàm:

=S_Find(Finds,Target,Colors,ForecolorDefault,Compare,UseRegex,Title)
Tham số :
Vị tríTham sốKiểuOptionalDiễn giải
1​
FindsChuỗi hoặc mảng chuỗiNhững chuỗi cần tìm kiếm
2​
TargetVùng đối tượngVùng cần tìm kiếm
3​
ColorsMàu hoặc Mảng màuNhững màu tô cho chuỗi đã tìm thấy
4​
ForecolorDefaultMàuMàu phông nếu không tìm thấy, Để là -1 thì giá trị là màu mặc định của dòng cột
5​
CompareCó/KhôngKhôngDạng so sánh hoa thường
6​
UseRegExCó/KhôngKhôngsử dụng Biểu thức chính quy (Bắt buộc kiến thức Regex)
7​
TitleChuỗiRỗngChuỗi trả về cho Ô nhập công thức (Không cần thiết)


=S_Find2(Finds,Source,Target,Colors,ForecolorDefault,Compare,UseRegex,Title)
Tham số :
Vị tríTham sốKiểuOptionalDiễn giải
1​
FindsChuỗi hoặc mảng chuỗiNhững chuỗi cần tìm kiếm
2​
SourceVùng ô hoặc giá trị tìm kiếm
3​
TargetVùng đối tượngVùng sẽ chép giá trị đến
4​
ColorsMàu hoặc Mảng màuNhững màu tô cho chuỗi đã tìm thấy
5​
ForecolorDefaultMàuMàu phông nếu không tìm thấy, Để là -1 thì giá trị là màu mặc định của dòng cột
6​
CompareCó/KhôngKhôngDạng so sánh hoa thường
7​
UseRegExCó/KhôngKhôngsử dụng Biểu thức chính quy (Bắt buộc kiến thức Regex)
8​
TitleChuỗiRỗngChuỗi trả về cho Ô nhập công thức (Không cần thiết)


Cách viết hàm nhanh, gõ vào ô chuỗi =S_Find và ấn tổ hợp phím Ctrl+Shift+A


Lưu ý*: Để sử dụng được Hàm S_Find trong dự án mới, hãy sao chép module mS_FindHighlight trong tệp hoặc sao chép code bên dưới


---------------------------------------------------------
find_and_highlight.jpg

JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit

Private Type TypeArguments
  Action As Long
  Formula As String
  Cells As Excel.Range
  Caller As Range
  Source As Variant
  Finds As Variant
  Target As Range
  colors As Variant
  ForecolorDefault As Long
  Compare As Boolean
  UseRegex As Boolean
  NewCell As Boolean
End Type

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private Works() As TypeArguments
Sub getColorsInCell()
  Dim i, r As Range, s$, v$, l&, ll:
  Set r = ActiveCell: s = r.Value
  For i = 1 To Len(s)
    l = r.Characters(i, 1).Font.color
    If Not IsEmpty(ll) Then
      If ll <> l Then
        v = v & IIf(v = "", "", ",") & ll
      End If
    End If
    ll = l
  Next
  Debug.Print v & IIf(v = "", "", ",") & ll
End Sub



Function S_Find2(Optional ByVal Finds, _
                  Optional ByVal Source, _
                  Optional ByVal Target As Range, _
                  Optional ByVal colors = vbRed, _
                  Optional ByVal ForecolorDefault& = -1, _
                  Optional ByVal Compare As Boolean = 0, _
                  Optional ByVal UseRegex As Boolean = 0, _
                  Optional ByVal Title As String = vbNullChar) As Variant
  
  Dim k As Integer, r, s$
  Set r = Application.Caller
  s = r.Formula
  If Title <> vbNullChar Then
    S_Find2 = Title
  Else
    S_Find2 = Mid(s, 2)
  End If
  On Error Resume Next
  k = UBound(Works)
  On Error GoTo 0
  s = r.Parent.Name & "_" & r.Address

  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = r.Formula
    .Action = 0
    If TypeName(Finds) = "Range" Then
      Set .Finds = Finds
    Else
      .Finds = Finds
    End If
    If TypeName(Source) = "Range" Then
      Set .Source = Source
    Else
      .Source = Source
    End If
    Set .Target = Target
    If TypeName(colors) = "Range" Then
      Set .colors = colors
    Else
      .colors = colors
    End If
    .Compare = Compare
    .UseRegex = UseRegex
    .ForecolorDefault = ForecolorDefault
    .NewCell = 1
  End With
  
  Call SetTimer(0&, 0&, 1, AddressOf S_FindHighlight_callback)
End Function

Function S_Find(Optional ByVal Finds, _
                  Optional ByVal Target As Range, _
                  Optional ByVal colors = vbRed, _
                  Optional ByVal ForecolorDefault& = -1, _
                  Optional ByVal Compare As Boolean = 0, _
                  Optional ByVal UseRegex As Boolean = 0, _
                  Optional ByVal Title As String = vbNullChar) As Variant
  
  Dim k As Integer, r, s$
  Set r = Application.Caller
  s = r.Formula
  If Title <> vbNullChar Then
    S_Find = Title
  Else
    S_Find = Mid(s, 2)
  End If
  On Error Resume Next
  k = UBound(Works)
  On Error GoTo 0
  s = r.Parent.Name & "_" & r.Address

  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k)
    Set .Caller = r
    Set .Cells = Cells
    .Formula = r.Formula
    .Action = 0
    If TypeName(Finds) = "Range" Then
      Set .Finds = Finds
    Else
      .Finds = Finds
    End If
    Set .Target = Target
    If TypeName(colors) = "Range" Then
      Set .colors = colors
    Else
      .colors = colors
    End If
    .Compare = Compare
    .UseRegex = UseRegex
    .ForecolorDefault = ForecolorDefault
  End With
  
  Call SetTimer(0&, 0&, 1, AddressOf S_FindHighlight_callback)
End Function

#If VBA7 And Win64 Then
Private Sub S_FindHighlight_callback(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub S_FindHighlight_callback(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal idEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub S_FindHighlight_callback(ByVal hWnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
' Last Edit: 08/02/2021 06:16
  On Error Resume Next
  KillTimer 0&, idEvent
  S_FindHighlight_working
  On Error GoTo 0
End Sub


Private Sub S_FindHighlight_working()

  Dim UA%
  Dim CR As Range
  Dim MS, M, R1, R2, i&, L1&, L2&, S1$, S2$, F&, k&, uK&, KK&
  Dim RE As Object, u&, FS(), color, e As Boolean, o
  Dim a As Object, b As TypeArguments, ee As Boolean, su As Boolean, ac As Long

  On Error Resume Next
  UA = UBound(Works)
On Error GoTo 0
  Dim s$
  For i = 1 To UA
    b = Works(i)
    Select Case b.Action
    Case 0
      Works(i).Action = 1
      If b.Caller.Formula = b.Formula Then
        If a Is Nothing Then
          Set a = b.Cells.Parent.Parent.Parent
          ee = Application.EnableEvents
          su = a.ScreenUpdating
          ac = a.Calculation
          If ee Then a.EnableEvents = False
          If su Then a.ScreenUpdating = False
          If ac <> xlCalculationManual Then a.Calculation = xlCalculationManual
        End If
        
        Set CR = Nothing
        If b.NewCell Then
          If TypeName(b.Source) = "Range" Then
            b.Target.Value = b.Source.Value
          Else
            b.Target(1, 1).Value = b.Source
          End If
        End If
        
        Set CR = b.Target
        If CR Is Nothing Then GoTo n
        Select Case TypeName(b.Finds)
        Case "Range":
          If TypeName(b.colors) = "Range" Then
            e = b.Finds.Address = b.colors.Address
          End If
        Case "Variant()":
        Case Else: b.Finds = Array(b.Finds)
        End Select

        If Not e Then
          Select Case TypeName(b.colors)
          Case "Range", "Variant()":
            For Each M In b.colors
              If IsNumeric(M) Then
                k = k + 1
                ReDim Preserve FS(1 To k):
                FS(k) = M
              End If
            Next
          Case Else: FS = Array(vbWhite, b.colors)
          End Select
          u = UBound(FS)
        End If

        For Each R1 In CR
          If b.ForecolorDefault <> -1 Then
            color = b.ForecolorDefault
          Else
            color = R1.Rows.Font.color
          End If

          S1 = CStr(R1.Value)
          L1 = Len(S1)
          GoSub format
          k = 0
          For Each R2 In b.Finds
            If Not e Then
              k = k + 1
              KK = ((k - 1) Mod u) + 1
            End If
            S2 = CStr(R2): L2 = Len(S2)
            If L2 > 0 Then
              If b.UseRegex Then
                GoSub HL2
              Else
                GoSub HL1
              End If
            End If
          Next
        Next
      Else
        Works(i).Action = 3
      End If
    End Select
n:
  Next

  Set RE = Nothing

  Erase Works

  If Not a Is Nothing Then
    If ee And a.EnableEvents <> ee Then
      a.EnableEvents = ee
    End If
    If su And a.ScreenUpdating <> su Then
      a.ScreenUpdating = su
    End If
    If ac And a.Calculation <> ac Then
      a.ScreenUpdating = ac
    End If
    Set a = Nothing
  End If
  On Error GoTo 0

Exit Sub

HL1:
  If L1 < L2 Then Return
  i = 1
  Do Until i >= L1
    i = InStr(i, S1, S2, -(Not b.Compare))
    If i = 0 Then Exit Do
    Set o = R1.Characters(Start:=i, Length:=L2).Font
    GoSub Style
    i = i + L2
  Loop
Return
HL2:
  If RE Is Nothing Then
    Set RE = VBA.CreateObject("VBScript.RegExp")
    With RE
      .Global = True
      .IgnoreCase = Not b.Compare
      .MultiLine = True
    End With
  End If
  RE.Pattern = S2
  Set MS = RE.Execute(S1)
  
  If MS.Count Then
    Dim t$
    For KK = 1 To MS.Count
      Set M = MS(KK - 1)
      t = M
      If M.SubMatches.Count Then
        Set o = R1.Characters(Start:=M.FirstIndex + InStr(1, t, M.SubMatches(0), 1), Length:=Len(M.SubMatches(0))).Font
      Else
        Set o = R1.Characters(Start:=M.FirstIndex + 1, Length:=M.Length).Font
      End If
      GoSub Style
    Next
  End If
Return
Style:
  With o
    If e Then
      .Name = R2.Font.Name
      .Italic = R2.Font.Italic
      .Size = R2.Font.Size
      .Bold = R2.Font.Bold
      .Strikethrough = R2.Font.Strikethrough
      .Superscript = R2.Font.Superscript
      .Subscript = R2.Font.Subscript
      .OutlineFont = R2.Font.OutlineFont
      .Shadow = R2.Font.Shadow
      .Underline = R2.Font.Underline
      .TintAndShade = R2.Font.TintAndShade
      .ThemeFont = R2.Font.ThemeFont
      .color = R2.Font.color
    Else
      .color = FS(KK)
    End If
  End With
Return
format:
  If color <> 0 Then R1.Characters(Start:=1, Length:=L1).Font.color = color
Return
End Sub
 

File đính kèm

  • S_FindText.xlsm
    40.9 KB · Đọc: 15
Lần chỉnh sửa cuối:
Cập nhật: tận dụng Group trong Biểu thức chính quy để tô màu
nhờ anh có thể chỉnh lại bỏ đi mục Colors được không anh? thay vì chỉ tô màu theo ô đã định thì mình có thể làm thế này
định dạng ngay trên chuỗi tìm kiếm, rồi hàm sẽ làm công việc định dạng y chang vậy. ví dụ ta định dạng chuỗi như vầy 1636822460098.png
thì hàm sẽ làm công việc định dạng y chang so với chuỗi tìm kiếm, như in đậm, in nghiêng, gạch chân, chỉ số trên, chỉ số dưới
vì không phải ai cũng biết đc mã màu mà gõ ra. em có xem code mà chả biết đường sửa vì code không chú thích, và viết tắt các biến nên em thua không chú thích được.
==================================
sau một hồi ngồi xem đã sửa code xong, ai thấy phù hợp thì sử dụng, cảm ơn tác giả HeSanbi vì mấy hàm quá hay như này.
em bỏ đi đối số thứ 3 mã màu sắc, có thể nhiều người không biết mã màu nên em lấy theo mặc định của ô chứa giá trị dò)
màu chữ vẫn giữ nguyên màu chữ mặc định của ô (của tác giả chuyển thành màu trắng)
hàm cho bảng 1: lấy định dạng của giá trị dò Finds
hàm tìm số: lấy định dạng của ô chứa công thức Application.Caller
hàm tìm kiếm: lấy định dạng của giá trị dò Finds
nguồn #1
 

File đính kèm

  • Find_Text1.xlsm
    37.9 KB · Đọc: 22
Lần chỉnh sửa cuối:
Upvote 0
nhờ anh có thể chỉnh lại bỏ đi mục Colors được không anh? thay vì chỉ tô màu theo ô đã định thì mình có thể làm thế này
định dạng ngay trên chuỗi tìm kiếm, rồi hàm sẽ làm công việc định dạng y chang vậy. ví dụ ta định dạng chuỗi như vầy
thì hàm sẽ làm công việc định dạng y chang so với chuỗi tìm kiếm, như in đậm, in nghiêng, gạch chân, chỉ số trên, chỉ số dưới
vì không phải ai cũng biết đc mã màu mà gõ ra. em có xem code mà chả biết đường sửa vì code không chú thích, và viết tắt các biến nên em thua không chú thích được.
==================================
sau một hồi ngồi xem đã sửa code xong, ai thấy phù hợp thì sử dụng, cảm ơn tác giả HeSanbi vì mấy hàm quá hay như này.
em bỏ đi đối số thứ 3 mã màu sắc, có thể nhiều người không biết mã màu nên em lấy theo mặc định của ô chứa giá trị dò)
màu chữ vẫn giữ nguyên màu chữ mặc định của ô (của tác giả chuyển thành màu trắng)
hàm cho bảng 1: lấy định dạng của giá trị dò Finds
hàm tìm số: lấy định dạng của ô chứa công thức Application.Caller
hàm tìm kiếm: lấy định dạng của giá trị dò Finds
nguồn #1
Đã cập nhật theo mong muốn của bạn
 
Upvote 0
Web KT
Back
Top Bottom