arrays - Excel拆分出不同颜色的数组
问题描述
我在下面的代码中得到了帮助,它就像一个梦一样工作,它从所有 5 个搜索文本框中找到单词,并以红色突出显示它们,并为其中一列添加计数。但是我想做同样的事情,但是对于框 1 的单词是红色的,框 2 的单词它发现它以绿色突出显示,框 3 以橙色等突出显示等。是否可以从数组中拆分出哪个文本框转到哪个部分的代码,那么我可以更改第二个完整的循环集以在第二个文本框中查找单词 n 并使单词变为绿色吗?
我希望这是有道理的?
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value,
UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1,
1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray
解决方案
像这样的东西会起作用。只需添加您可以在每个循环周期中引用的 RGB 值的第二个数组。
Sub TestColor()
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant, myColors As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
With UsrFormSearch ' Think the .Value is superfluous - add back in if issues arise
mywords = Array(.TxtSearch1, .TxtSearch2, .TxtSearch3, .TxtSearch4, .TxtSearch5)
End With
myColors = Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 0, 255), RGB(0, 0, 255))
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = myColors(m)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray
End Sub
推荐阅读
- java - Java 字符串长度无法正常工作
- r - 仅对数据框中的可用列求和
- sql-server - AnyConnect 开启时 Azure Ubuntu VM 上的 MSSQL 超时错误
- image - 如何使用 Gabor 滤波器检测对象?
- vert.x - 用于连接 Solace VMR 服务器的 VertX 客户端实现
- apache - Apache 反向代理授权标头
- notepad++ - Notepad ++折叠,使用与打开和关闭相同的字符?
- angular - 发送操作后,ngrx 减速器未触发
- python-3.x - 使用pyautogui解锁屏幕
- r - 使用 R 抓取 FIFA 比赛统计数据