HeSanbi
Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
- Tham gia
- 24/2/13
- Bài viết
- 2,383
- Được thích
- 3,552
- 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:
Tham số :
Tham số :
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
---------------------------------------------------------
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) |
Vị trí | Tham số | Kiểu | Optional | Diễn giải |
1 | Finds | Chuỗi hoặc mảng chuỗi | Những chuỗi cần tìm kiếm | |
2 | Target | Vùng đối tượng | Vùng cần tìm kiếm | |
3 | Colors | Màu hoặc Mảng màu | Những màu tô cho chuỗi đã tìm thấy | |
4 | ForecolorDefault | Màu | Mà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 | Compare | Có/Không | Không | Dạng so sánh hoa thường |
6 | UseRegEx | Có/Không | Không | sử dụng Biểu thức chính quy (Bắt buộc kiến thức Regex) |
7 | Title | Chuỗi | Rỗng | Chuỗ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) |
Vị trí | Tham số | Kiểu | Optional | Diễn giải |
1 | Finds | Chuỗi hoặc mảng chuỗi | Những chuỗi cần tìm kiếm | |
2 | Source | Vùng ô hoặc giá trị tìm kiếm | ||
3 | Target | Vùng đối tượng | Vùng sẽ chép giá trị đến | |
4 | Colors | Màu hoặc Mảng màu | Những màu tô cho chuỗi đã tìm thấy | |
5 | ForecolorDefault | Màu | Mà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 | Compare | Có/Không | Không | Dạng so sánh hoa thường |
7 | UseRegEx | Có/Không | Không | sử dụng Biểu thức chính quy (Bắt buộc kiến thức Regex) |
8 | Title | Chuỗi | Rỗng | Chuỗ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
---------------------------------------------------------
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
Lần chỉnh sửa cuối: