同时打开一个文件下的三张表进行数据处理，为什么只有第一张表成功其他都变成空白表

y256789

1. Sub kd()
   
2. Dim wb As Workbook
   
3. Dim str As String
   
4. t = Timer
   
5. ss = "12"
   
6. st = "B"
   
7. sr = "J"
   
8. k = 1
   
9. Application.ScreenUpdating = False
   
10. str = Dir("d:\data\*.xls*")
    
11. For Z = 1 To 3
    
12.    Set wb = Workbooks.Open("d:\data" & str)
    
13.    Dim arr1(), arr2(), arr3(), arr4()
    
14.    For m = 3 To 2 Step -1
    
15.    ActiveSheet.Rows(m).Delete
    
16.    Next
    
17.    arr1 = [a1].CurrentRegion.Value2
    
18.    ReDim arr2(1 To UBound(arr1), 1 To UBound(arr1, 2))
    
19.    ReDim arr3(1 To UBound(arr1), 1 To UBound(arr1, 2))
    
20.    ReDim arr4(1 To UBound(arr1), 1 To UBound(arr1, 2))
    
21. 
    
22.    For i = 1 To UBound(arr1)
    
23.       If InStr(ss, Mid(arr1(i, 2), 6, 2)) <> 0 Then
    
24.          k = k + 1
    
25.          For j = 1 To UBound(arr1, 2)
    
26.             arr2(1, j) = arr1(1, j)
    
27.             arr2(k, j) = arr1(i, j)
    
28.          Next
    
29.       End If
    
30.    Next

复制代码

y256789

行数限制 一楼代码不全
再说一下问题，运行时，我可以看到第三个表也成功处理，但最后屏幕闪了一下，第二三个表就变成空白了
下面是代码
Sub kd()
Dim wb As Workbook
Dim str As String
t = Timer
ss = "12"
st = "B"
sr = "J"
k = 1
Application.ScreenUpdating = False
str = Dir("d:\data\*.xls*")
For Z = 1 To 3
    Set wb = Workbooks.Open("d:\data\" & str)
        Dim arr1(), arr2(), arr3(), arr4()
        For m = 3 To 2 Step -1
        ActiveSheet.Rows(m).Delete
        Next
        arr1 = [a1].CurrentRegion.Value2
        ReDim arr2(1 To UBound(arr1), 1 To UBound(arr1, 2))
        ReDim arr3(1 To UBound(arr1), 1 To UBound(arr1, 2))
        ReDim arr4(1 To UBound(arr1), 1 To UBound(arr1, 2))
        
        
        For i = 1 To UBound(arr1)
            If InStr(ss, Mid(arr1(i, 2), 6, 2)) <> 0 Then
                k = k + 1
                For j = 1 To UBound(arr1, 2)
                    arr2(1, j) = arr1(1, j)
                    arr2(k, j) = arr1(i, j)
                Next
            End If
        Next
        
        
        For m = 1 To UBound(arr2)
            If InStr(st, arr2(m, 3)) = 0 Then
                w = w + 1
                For n = 1 To UBound(arr2, 2)
                    arr3(w, n) = arr2(m, n)
                Next
            End If
        Next
        
        
        For p = 1 To UBound(arr3)
            If InStr(sr, Left(arr3(p, 4), 1)) = 0 Then
                r = r + 1
                For q = 1 To UBound(arr3, 2)
                    arr4(r, q) = arr3(p, q)
                Next
            End If
        Next
                 
                 
       ActiveSheet.[a1].Resize(UBound(arr1), UBound(arr4, 2)) = arr4
        
    wb.Save
    wb.Close savechanges:=False
        
    str = Dir
    If str = "" Then Exit For
   
Next
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

y256789

由于行数限制，一楼没有代码全部，下面是全部代码
Sub kd()
Dim wb As Workbook
Dim str As String
t = Timer
ss = "12"
st = "B"
sr = "J"
k = 1
Application.ScreenUpdating = False
str = Dir("d:\data\*.xls*")
For Z = 1 To 3
    Set wb = Workbooks.Open("d:\data\" & str)
        Dim arr1(), arr2(), arr3(), arr4()
        For m = 3 To 2 Step -1
        ActiveSheet.Rows(m).Delete
        Next
        arr1 = [a1].CurrentRegion.Value2
        ReDim arr2(1 To UBound(arr1), 1 To UBound(arr1, 2))
        ReDim arr3(1 To UBound(arr1), 1 To UBound(arr1, 2))
        ReDim arr4(1 To UBound(arr1), 1 To UBound(arr1, 2))
        
        
        For i = 1 To UBound(arr1)
            If InStr(ss, Mid(arr1(i, 2), 6, 2)) <> 0 Then
                k = k + 1
                For j = 1 To UBound(arr1, 2)
                    arr2(1, j) = arr1(1, j)
                    arr2(k, j) = arr1(i, j)
                Next
            End If
        Next
        
        
        For m = 1 To UBound(arr2)
            If InStr(st, arr2(m, 3)) = 0 Then
                w = w + 1
                For n = 1 To UBound(arr2, 2)
                    arr3(w, n) = arr2(m, n)
                Next
            End If
        Next
        
        
        For p = 1 To UBound(arr3)
            If InStr(sr, Left(arr3(p, 4), 1)) = 0 Then
                r = r + 1
                For q = 1 To UBound(arr3, 2)
                    arr4(r, q) = arr3(p, q)
                Next
            End If
        Next
                 
                 
       ActiveSheet.[a1].Resize(UBound(arr1), UBound(arr4, 2)) = arr4
        
    wb.Save
    wb.Close savechanges:=False
        
    str = Dir
    If str = "" Then Exit For
   
Next
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

lss001

去掉→wb.Save
把    →wb.Close savechanges:=False
改为→wb.Close savechanges:=True

y256789

lss001 发表于 2019-6-12 10:02
去掉→wb.Save
把    →wb.Close savechanges:=False
改为→wb.Close savechanges:=True

还是不行，55555，原文件数据有点多，压缩后也传不上来。还是第一个表处理成功的，剩下两个表就依然是空表

lss001

y256789 发表于 2019-6-13 20:17
还是不行，55555，原文件数据有点多，压缩后也传不上来。还是第一个表处理成功的，剩下两个表就依然是空 ...

在→Set wb = Workbooks.Open("d:\data\" & str)
后面增加激活工作薄！→wb.Activate

y256789

lss001 发表于 2019-6-13 20:54
在→Set wb = Workbooks.Open("d:\data\" & str)
后面增加激活工作薄！→wb.Activate

额 这次 出现了新问题，第一张表可以成功处理，第二张表依然为空，第三张表不是空表但是没有进行处理

lss001

__________