下边是示例图片和代码,还有空间变量名说明
Private Sub Cmd_Find_Click()
'字符数大于4个才开始查找
If Len(T_FindStr.Text) < 4 Then
MsgBox "请输入字符大于4个才能查找,否则不予查找,会导致找到大量数据泛滥"
ElseIf Len(T_FindStr.Text) > 4 Then
btnNext_Click T_FindStr.Text
End If
End Sub
Private Sub cmd_FindStr_Next_Click()
If Comb_list_FindStr.ListIndex < Comb_list_FindStr.ListCount - 1 Then
Comb_list_FindStr.ListIndex = Comb_list_FindStr.ListIndex + 1
End If
End Sub
Private Sub Sub_Active_FindCell(ByVal i_FindStr)
'激活找到的单元格
Dim selectedValue As String
Dim foundCell As Range
Dim ws As Worksheet
' 获取组合框中被选中的值
selectedValue = i_FindStr
' 在整个工作簿中查找对应值的单元格
For Each ws In ThisWorkbook.Worksheets
Set foundCell = ws.Cells.Find(What:=selectedValue, After:=ws.Cells(1, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
' 如果找到对应值的单元格
If Not foundCell Is Nothing Then
' 跳转到对应值的单元格所在的工作表和单元格
foundCell.Worksheet.Activate
On Error Resume Next
foundCell.Select
Exit For
End If
Next ws
' 如果没有找到对应值的单元格
If foundCell Is Nothing Then
'MsgBox "未找到对应值的单元格。"
End If
End Sub
Private Sub Comb_list_FindStr_Change()
Sub_Active_FindCell Comb_list_FindStr.Value
End Sub
Private Sub Comb_Style_Change()
Select Case Comb_Style.Text
Case Is = "开关量"
T_Find_Col.Text = 3
T_type = "DO"
Case Is = "模拟量"
T_Find_Col.Text = 3
T_type = "AI"
End Select
End Sub
Private Sub Comb_Style_DaDian_Change()
Dim S_Tem$
S_Tem = Comb_Style_DaDian.Text
Select Case S_Tem
Case Is = "已打点"
T_Color_No.Text = 5296274
Case Is = "未打点"
T_Color_No.Text = 16777215
Case Is = "故障"
T_Color_No.Text = 255
Case Is = "取消"
T_Color_No.Text = 65535
End Select
End Sub
Private Sub CommandButton1_Click()
'仪表阀门未接线统计,非透明颜色可以用该函数统计,透明颜色需要用单独函数统计
Dim ws As Worksheet, WS1 As Worksheet
Dim LastRow As Long, countColor As Long
Dim i As Long, i_Row As Long, i_Col As Long
Dim Sz_valve(1000, 100) As Variant
Dim S_Name$, S_Tem$, S_Type As String, S_tem1 As String
Dim DCS_No As Integer, I_find_col As Long, I_FenXi_col As Long, Get_Col_Str As Long, Get_Col_End As Long
Dim S_Sht_Name$, Writ_Row_Str As Long
Dim DCS_Name As String
Dim SZ_DCS_Name As Variant
'获取所有工作表名称,然后提取符合DCS的工作表,进行记录,为后续每个表的统计做准备
DCS_Name = ""
For i = 1 To Sheets.Count
If InStr(Worksheets(i).Name, "DCS") > 0 Then
DCS_Name = DCS_Name & Worksheets(i).Name & ","
End If
Next i
DCS_Name = Left(DCS_Name, Len(DCS_Name) - 1)
SZ_DCS_Name = Split(DCS_Name, ",") '包含所有DCS的工作表的名称的数组
S_Sht_Name = T_sht_Name.Text '本表格名称
I_find_col = T_Find_Col.Text '分类查找所在列
I_FenXi_col = T_FenXi_Col.Text '分析所在列
S_Type = T_type.Text '包含种类字符
Get_Col_Str = T_Get_Col_Str.Text
Get_Col_End = T_Get_Col_End.Text
Writ_Row_Str = T_Writ_Row_Str.Text
'------------------------------------------------------------------
Set WS1 = ThisWorkbook.Sheets(S_Sht_Name)
i_Row = 2
i_Col = 2
For DCS_No = LBound(SZ_DCS_Name) To UBound(SZ_DCS_Name)
S_Name = SZ_DCS_Name(DCS_No)
' 设置要检查的工作表
Set ws = ThisWorkbook.Sheets(S_Name)
' 获取该列最后一行的行号
LastRow = ws.Cells(ws.Rows.Count, I_find_col).End(xlUp).Row
' 初始化计数器
countColor = 0
' 从第6行开始遍历该列的单元格
For i = 6 To LastRow
S_Tem = ws.Cells(i, I_find_col).Value
S_tem1 = ws.Cells(i, I_FenXi_col).Value
' 统计DO
If InStr(S_Tem, "Spare") < 1 And InStr(S_tem1, S_Type) > 0 Then
' 检查单元格的背景颜色,符合包含分析的数据
If ws.Cells(i, I_find_col).Interior.COLOR = T_Color_No.Text Then
countColor = countColor + 1
'获取所需要列的数据写入数组
For k = 0 To Get_Col_End - Get_Col_Str + 1
Sz_valve(countColor, k) = ws.Cells(i, Get_Col_Str + k).Value
Next k
End If
End If
Next i
'写入excel内容
tem_s = ""
For i = Writ_Row_Str To Writ_Row_Str + countColor - 1
For k = Get_Col_End - Get_Col_Str + 1 To 0 Step -1
tem_s = tem_s & "|" & Sz_valve(i - Writ_Row_Str, k)
Next k
WS1.Cells(i, DCS_No).Value = S_Name & "|" & tem_s
tem_s = ""
Next i
Next DCS_No
End Sub
Sub SelectCells(ByVal i_N As Integer)
Dim currentCell As Range
Set currentCell = ActiveCell
' 选中当前单元格
currentCell.Select
' 选中同行右侧两个单元格
currentCell.Offset(0, 0).Resize(1, i_N).Select
End Sub
Private Sub Lb_Red_Click() '红色
SelectCells T_SetColor_Col.Text '同时3列标记
With Selection.Interior
.PatternColorIndex = xlAutomatic
.COLOR = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Private Sub Lb_Yel_Click() '黄色
SelectCells T_SetColor_Col.Text '同时3列标记
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.COLOR = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Private Sub Lb_Green_Click() '绿色
SelectCells T_SetColor_Col.Text '同时3列标记
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.COLOR = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Private Sub Lb_TouMing_Click() '透明
SelectCells T_SetColor_Col.Text '同时3列标记
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Private Sub Lb_GetColor_Click()
T_Color_No.Text = Selection.Interior.COLOR
Lb_GetColor.BackColor = T_Color_No.Text
End Sub
'超级查找
Private Sub btnNext_Click(i_FindStr)
Dim searchTerm As String
Dim foundCell As Range
Dim firstAddress As String
Dim ws As Worksheet
' 获取要查找的关键字
searchTerm = i_FindStr
' 清空组合框中的内容
Comb_list_FindStr.Clear
list_FindStr.Clear
' 在整个工作簿中查找包含关键字的单元格
For Each ws In ThisWorkbook.Worksheets
Set foundCell = ws.Cells.Find(What:=searchTerm, After:=ws.Cells(1, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
' 如果找到匹配的单元格
If Not foundCell Is Nothing Then
' 保存第一个匹配单元格的地址
firstAddress = foundCell.Address
' 将结果列出到组合框和列表框中
Comb_list_FindStr.AddItem foundCell.Value
list_FindStr.AddItem foundCell.Value
' 继续查找下一个匹配单元格
Do
' 查找下一个匹配单元格
Set foundCell = ws.Cells.FindNext(After:=foundCell)
' 如果找到了下一个匹配单元格
If Not foundCell Is Nothing Then
' 将结果列出到组合框和列表框中
Comb_list_FindStr.AddItem foundCell.Value
list_FindStr.AddItem foundCell.Value
End If
Loop Until foundCell Is Nothing Or foundCell.Address = firstAddress
End If
Next ws
' 如果没有找到匹配的单元格
If Comb_list_FindStr.ListCount = 0 Then
'MsgBox "未找到包含关键字的单元格。"
Else
Comb_list_FindStr.ListIndex = 0 '自动跳转
End If
End Sub
Private Sub Comb_list_FindStr_Click()
Sub_Active_FindCell Comb_list_FindStr.Value
End Sub
Private Sub list_FindStr_Click()
Sub_Active_FindCell list_FindStr.Value
End Sub
Private Sub List_Process_Style_Click()
Dim SZ_Style As Variant
Dim i%, Str_No%, S_Tem$, S_tem1$
S_tem1 = T_FindStr.Text
'直接替换介质代号
If InStr(S_tem1, "-") > 0 Then
SZ_Style = Split(T_FindStr, "-")
Str_No = 0
For i = 1 To Len(SZ_Style(1))
If IsNumeric(Mid(SZ_Style(1), i, 1)) = True Then
Str_No = i
Exit For
End If
Next i
If Str_No = 0 Then
S_Tem = SZ_Style(0) & "-" & List_Process_Style.Value
Else
S_Tem = SZ_Style(0) & "-" & List_Process_Style.Value & Mid(SZ_Style(1), Str_No, Len(SZ_Style(1)) - Str_No + 1)
End If
Else
S_Tem = ""
S_Tem = T_FindStr.Text & List_Process_Style.Value
End If
T_FindStr.Text = S_Tem
End Sub
Private Sub List_YBStyle_Click()
Dim SZ_Style As Variant
If InStr(T_FindStr.Text, "-") > 0 Then
SZ_Style = Split(T_FindStr, "-")
T_FindStr.Text = List_YBStyle.Value & SZ_Style(1)
Else
T_FindStr.Text = List_YBStyle.Value & T_FindStr.Text
End If
End Sub
Private Sub T_Color_No_Change()
On Error Resume Next
Lb_GetColor.BackColor = T_Color_No.Text
End Sub
Private Sub T_FindStr_Change()
'字符数大于4个才开始查找
If Len(T_FindStr.Text) > T_FindStr_Len.Text And Len(T_FindStr.Text) > 3 Then
btnNext_Click T_FindStr.Text
End If
End Sub
Private Sub T_FindStr_Len_Change()
If T_FindStr_Len.Text < 3 Then
MsgBox "禁止将数值设置成小于3的数,会查出大量数据导致excel崩溃!!建议设置成7!!"
T_FindStr.Text = 3
End If
End Sub
Private Sub UserForm_Initialize()
Dim SZ_Style As Variant, SZ_Style_DaDian As Variant
Dim S_Style As String, S_Style_DaDian As String
Dim S_Style_YB$, SZ_Style_YB As Variant
Dim S_Process_Style$, SZ_Process_Style As Variant
Dim i%
S_Style = "开关量,模拟量"
SZ_Style = Split(S_Style, ",")
For i = LBound(SZ_Style) To UBound(SZ_Style)
Comb_Style.AddItem SZ_Style(i)
Next i
Comb_Style.ListIndex = 0
S_Style_DaDian = "已打点,未打点,故障,取消"
SZ_Style_DaDian = Split(S_Style_DaDian, ",")
For i = LBound(SZ_Style_DaDian) To UBound(SZ_Style_DaDian)
Comb_Style_DaDian.AddItem SZ_Style_DaDian(i)
Next i
Comb_Style_DaDian.ListIndex = 0
'类型
S_Style_YB = "TT,PT,LT,LS,FT,PH,CT,AT,WT,HV,XV,XO,XC,AV,FV,WV"
SZ_Style_YB = Split(S_Style_YB, ",")
For i = LBound(SZ_Style_YB) To UBound(SZ_Style_YB)
List_YBStyle.AddItem SZ_Style_YB(i) & "-"
Next i
List_YBStyle.ListIndex = 0
S_Process_Style = "R,V,P,E,X,BWS,CWS,LS,DW,NY,N,IA,CA"
SZ_Process_Style = Split(S_Process_Style, ",")
For i = LBound(SZ_Process_Style) To UBound(SZ_Process_Style)
List_Process_Style.AddItem SZ_Process_Style(i)
Next i
List_Process_Style.ListIndex = 0
Lb_GetColor.BackColor = T_Color_No
End Sub