想在检索表里实现按合同编号和施工单位模糊查找筛选的，但是总是提示下标越界，检索出的内容也只显示8列的内容，其他的都显示不出来，求大神赐教指导下！ - VB6论坛

楼主

已结贴√ 问题点数：20 回复次数：5

想在检索表里实现按合同编号和施工单位模糊查找筛选的，但是总是提示下标越界，检索出的内容也只显示8列的内容，其他的都显示不出来，求大神赐教指导下！

Sub gj23w98()
Dim brr(1 To 5000, 1 To 28)

新建 Microsoft Office Excel 2007 工作簿.zip (939.97 KB)

    For Each sht In Sheets
        If sht.Name <> ActiveSheet.Name Then
            With sht
                 r = .Cells(.Rows.Count, 1).End(3).Row
                 arr = .Range("a3:i" & r)
            End With
            For i = 1 To UBound(arr)
                If InStr(arr(i, 3), [c1]) > 0 Or InStr(arr(i, 20), [f1]) > 0 Then
                    m = m + 1
                    For j = 1 To UBound(arr, 2)
                       brr(m, j) = arr(i, j)
                    Next
                End If
            Next
        End If
    Next
    If m > 0 Then
        Range("a3:i" & Rows.Count).ClearContents
        [a3].Resize(m, 28) = brr
    Else
        MsgBox "没有找到相关数据，请查证！"
    End If
End Sub

搜索更多相关主题的帖子: 检索　内容　显示　 If　End　

第 2 楼

得分:10

用如下代码覆盖原代码应该可以达到楼主的要求（注释部分注明了修改内容）
Sub gj23w98()
Dim brr(1 To 5000, 1 To 28)
    Sheets("检索表").Range("A3:AB5000").Clear   '清除检索表上次检索的全部内容
    For Each sht In Sheets
        If sht.Name <> ActiveSheet.Name Then
            With sht
                 r = .Cells(.Rows.Count, 2).End(3).Row
                 arr = .Range("a3:AB" & r)      '原代码到I列，现改到AB列可显示全部列内容
            End With
            For i = 1 To UBound(arr)
                If (InStr(arr(i, 3), [c1]) > 0 And [c1] <> "") Or (InStr(arr(i, 20), [f1]) > 0 And [f1] <> "") Then
                '施工单位和合同编号的共同检索必须排除空字符的情况
                    m = m + 1
                    For j = 1 To UBound(arr, 2)
                       brr(m, j) = arr(i, j)
                    Next
                End If
            Next
        End If
    Next
    If m > 0 Then
        Range("a3:i" & Rows.Count).ClearContents
        [a3].Resize(m, 28) = brr
    Else
        MsgBox "没有找到相关数据，请查证！"
    End If
End Sub

能编个毛线衣吗？

第 3 楼

得分:10

Sub gj23w98()
Dim brr(1 To 5000, 1 To 28)
Range("a3:ab" & Rows.Count).ClearContents
    For Each sht In Sheets
        If sht.Name <> ActiveSheet.Name Then
            With sht
                 r = .Cells(.Rows.Count, 2).End(3).Row
                 arr = .Range("a3:ab" & r)
            End With
            For i = 1 To UBound(arr)
                If [c1] <> "" And [f1] <> "" Then
                    If InStr(arr(i, 3), [c1]) > 0 And InStr(arr(i, 20), [f1]) > 0 Then
                        m = m + 1
                        For j = 1 To UBound(arr, 2)
                           brr(m, j) = arr(i, j)
                        Next
                    End If
                Else
                     If [c1] <> "" Then
                        If InStr(arr(i, 3), [c1]) > 0 Then
                            m = m + 1
                            For j = 1 To UBound(arr, 2)
                                brr(m, j) = arr(i, j)
                            Next
                        End If
                    Else
                        If [f1] <> "" Then
                            If InStr(arr(i, 20), [f1]) > 0 Then
                                m = m + 1
                                For j = 1 To UBound(arr, 2)
                                    brr(m, j) = arr(i, j)
                                Next
                            End If
                        End If
                     End If

                End If
            Next
        End If
    Next
    If m > 0 Then
        [a3].Resize(m, 28) = brr
    Else
        MsgBox "没有找到相关数据，请查证！"
    End If
End Sub
~~~~~~~~~~~~~~~~~~~~~~
小小菜鸟，折腾了一早上，学习ing