Excel 表格的【超级查找功能】EXCEL表格自动查找

最新推荐文章于 2024-05-03 10:30:24 发布
菌王
最新推荐文章于 2024-05-03 10:30:24 发布
阅读量140
点赞数
分类专栏： VBA程序文章标签： excel
本文链接：https://blog.csdn.net/VB973490770/article/details/134107056
版权
VBA程序专栏收录该内容
2 篇文章 0 订阅
订阅专栏
下边是示例图片和代码，还有空间变量名说明



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