关于多表格筛选问题

rio123

bajifeng 发表于 2015-12-21 15:14
把 另一个表格的名字 说一下。

就拿这个表格来说，不查询、不提前A公司的数据

bajifeng

加上两句
Sub bajifeng()    'bajifeng
Dim brr()
s = [a2] & [b2] & [c2]
b = IIf([b2] = 0, 0, 1)
Sheets(1).UsedRange.Offset(4).Clear
For Each sh In Sheets
    i = 0
    If InStr(sh.Name, "筛") = 0 Then
                If InStr(sh.Name, "A公司") = 0 Then
        sh.Activate
        lr = sh.[a65536].End(3).Row
        arr = sh.Range([a2], Cells(lr, "g"))
        For i = 1 To UBound(arr)
            If b = 1 And InStr(arr(i, 1) & arr(i, 2) & arr(i, 4), s) > 0 Then
                n = n + 1
                ReDim Preserve brr(1 To 7, 1 To n)
                For j = 1 To 7
                    brr(j, n) = arr(i, j)
                Next
            ElseIf b = 0 And InStr(arr(i, 1) & arr(i, 4), s) > 0 Then
                n = n + 1
                ReDim Preserve brr(1 To 7, 1 To n)
                For j = 1 To 7
                    brr(j, n) = arr(i, j)
                Next
            End If
        Next
                End If
    End If
Next
Sheets(1).Activate
[a5:g5].Resize(UBound(brr, 2)) = Application.Transpose(brr)
End Sub

bajifeng

加上两句，如楼上红色标出的语句所示。

rio123

bajifeng 发表于 2015-12-21 16:04
加上两句
Sub bajifeng()    'bajifeng
Dim brr()

完美解决，非常感谢

rio123

bajifeng 发表于 2015-12-21 16:06
加上两句，如楼上红色标出的语句所示。

您好，还有个问题想请您帮忙解决一下：我增加了一个目录，但是如果把“筛选结果”窗口放在“目录”前面，筛选会报错，如果把“筛选结果”放在“目录”之后，筛选的结果会出现在“目录”窗口中，麻烦您帮忙解决一下，非常感谢！！！如下图

03A 多表格筛选(增加目录).rar (36.94 KB, 下载次数: 14)

2015-12-21 17:26 上传

点击文件名下载附件

bajifeng

1. Sub bajifeng()    'bajifeng
   
2. 'http://club.excelhome.net/thread-1246855-2-1.html
   
3. Dim brr()
   
4. s = [a2] & [b2] & [c2]
   
5. b = IIf([b2] = 0, 0, 1)
   
6. Sheets("筛选结果").UsedRange.Offset(4).Clear
   
7. For Each Sh In Sheets
   
8.     i = 0
   
9.     If InStr(Sh.Name, "筛") = 0 Then
   
10.              If InStr(Sh.Name, "目录") = 0 Then
    
11.         Sh.Activate
    
12.         lr = Sh.[a65536].End(3).Row
    
13.         arr = Sh.Range([a2], Cells(lr, "g"))
    
14.         For i = 1 To UBound(arr)
    
15.             If b = 1 And InStr(arr(i, 1) & arr(i, 2) & arr(i, 4), s) > 0 Then
    
16.                 n = n + 1
    
17.                 ReDim Preserve brr(1 To 7, 1 To n)
    
18.                 For j = 1 To 7
    
19.                     brr(j, n) = arr(i, j)
    
20.                 Next
    
21.             ElseIf b = 0 And InStr(arr(i, 1) & arr(i, 4), s) > 0 Then
    
22.                 n = n + 1
    
23.                 ReDim Preserve brr(1 To 7, 1 To n)
    
24.                 For j = 1 To 7
    
25.                     brr(j, n) = arr(i, j)
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.              End If
    
30.     End If
    
31. Next
    
32. Sheets("筛选结果").Activate
    
33. [a5:g5].Resize(UBound(brr, 2)) = Application.Transpose(brr)
    
34. End Sub

复制代码

bajifeng

>>>>>>>>>>>>>>>>

rio123

bajifeng 发表于 2015-12-21 18:19
>>>>>>>>>>>>>>>>

谢谢您的帮忙，运行时还是报错！麻烦帮忙调试一下，谢谢

bajifeng

rio123 发表于 2015-12-22 08:27
谢谢您的帮忙，运行时还是报错！麻烦帮忙调试一下，谢谢

运行时，你的工作簿是否存在 B公司这个工作表呢？

rio123

bajifeng 发表于 2015-12-22 08:31
运行时，你的工作簿是否存在 B公司这个工作表呢？

存在的，就是下载附件直接运行报错的