| 网站首页 | 业界新闻 | 群组 | 交易 | 人才 | 下载频道 | 博客 | 代码贴 | 编程论坛
共有 261 人关注过本帖
标题:想在检索表里实现按合同编号和施工单位模糊查找筛选的,但是总是提示下标越 ...
只看楼主 加入收藏
aigyj1
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2018-10-7
结帖率:0
  已结贴   问题点数:20  回复次数:5   
想在检索表里实现按合同编号和施工单位模糊查找筛选的,但是总是提示下标越界,检索出的内容也只显示8列的内容,其他的都显示不出来,求大神赐教指导下!
Sub gj23w98()
 Dim brr(1 To 5000, 1 To 28)
    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
附件: 您没有浏览附件的权限,请 登录注册
2018-10-07 23:29
wmf2014
Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18
等 级:贵宾
威 望:156
帖 子:1717
专家分:9556
注 册:2014-12-6
  得分: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

能编个毛线衣吗?
2018-10-08 10:57
yingshu
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:4
帖 子:35
专家分:133
注 册:2018-7-24
  得分: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
2018-10-08 11:41
aigyj1
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2018-10-7
  得分:0 
回复 2楼 wmf2014
太感谢您了我再试试,之前一直没找到问题出在哪里了,谢谢您
2018-10-08 17:06
aigyj1
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2018-10-7
  得分:0 
回复 3楼 yingshu
谢谢您看了您的代码,恍然大悟,知道我的问题出在哪里了,又学习了
2018-10-08 17:10
aigyj1
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2018-10-7
  得分:0 
回复 3楼 yingshu
代码试了,很好用,正是我想实现的效果,太感谢了,解决了我的难题
2018-10-09 13:41







关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.024180 second(s), 8 queries.
Copyright©2004-2018, BCCN.NET, All Rights Reserved