为何按顺序删除表出错？如何实现把前面4个中文表名的表删除？

棋行天下黄

有个工作簿里面有很多表，首先要把武汉的筛选出来，然后把武汉的数据一张张的粘贴到新表中，把原始数据表一张张删除，结果原始数据表没删干净，结果处理后的数据表却删掉了，到底哪里出错了？
Sub 必出样报表筛选武汉()
    Application.DisplayAlerts = False
    s = Sheets.Count
    MsgBox (s)
       For i = 1 To s
       Sheets(i).Select
       sh = Sheets(i).name
            ActiveSheet.AutoFilterMode = False
        Sheets(i).Rows("1:1").Select
        
            Selection.AutoFilter
        A = Sheets(i).[A1048576].End(3).Row
        B = Sheets(i).[IV1].End(xlToLeft).Column
        If Sheets(i).Cells(1, 4).Value = "分部" Then
        Sheets(i).Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=4, Criteria1:="=*武汉*"
        End If
        If Sheets(i).Cells(1, 8).Value = "分部" Then
        Sheets(i).Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=8, Criteria1:="=*武汉*"
        End If
      
    Sheets(i).Range(Cells(1, 1), Cells(A, B)).Select
        Selection.Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
          sheetS(SH).DELETE
        Next i
        
      
      
      End Sub
那些中文表名的表为何没删干净，反而把处理后的数据表删掉了？

风林火山

Sub 合并明细表()
    Dim arr, brr(1 To 10000, 1 To 20), k&, i&, n&, sh

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        arr = sh.Range("a1").CurrentRegion
        For k = 2 To UBound(arr)
            If InStr(arr(k, 4), "武汉") > 0 Then
                n = n + 1
                For i = 1 To UBound(arr, 2)
                    brr(n, i) = arr(k, i)
                Next i
            End If
        Next k
        Erase arr
    Next sh
    Worksheets.Add
    ActiveSheet.Name = "合并明细"
    Sheets("彩电").Range("a1:t1").Copy Range("a1")
    Range("a2").Resize(10000, 20) = brr
    Cells.EntireColumn.AutoFit
    For Each sh In Worksheets
        If sh.Name <> "合并明细" Then sh.Delete
    Next sh
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

棋行天下黄

风林火山 发表于 2014-1-26 20:33
Sub 合并明细表()
    Dim arr, brr(1 To 10000, 1 To 20), k&, i&, n&, sh

谢谢帮助，但未解决问题，我的模板举个列，实际另外一个工作簿里面有两张原始数据表，一张是电脑，一张是小家电，故你的程序没有通用性。通用性的程序有一个，但03版能用，10版错误
Sub 必出样报表筛选武汉()
  Dim d As New Dictionary
  Dim ws As Worksheet
  Application.DisplayAlerts = False
  For Each ws In Worksheets
    d(ws.name) = ""
  Next
  arr = d.Keys
  For i = 0 To UBound(arr)
    With Worksheets(arr(i))
        .Select
        ActiveSheet.AutoFilterMode = False
       .Rows(1).Select
       Selection.AutoFilter
       A = .[A1048576].End(3).Row
       B = .[IV1].End(xlToLeft).Column
       If .Cells(1, 4).Value = "分部" Then
        .Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=4, Criteria1:="=*武汉*"
       End If
       If .Cells(1, 8).Value = "分部" Then
         .Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=8, Criteria1:="=*武汉*"
       End If
      
       .Range(.Cells(1, 1), .Cells(A, B)).Select
       Selection.Copy
       Worksheets.Add After:=Worksheets(Worksheets.Count)
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
           :=False, Transpose:=False
       .Delete
     End With
   Next
End Sub

风林火山

哦，这样啊，下次把通用的表发上来

棋行天下黄

风林火山 发表于 2014-1-26 21:04
哦，这样啊，下次把通用的表发上来

Sub 必出样报表筛选武汉()
  Dim d As Object
  Dim ws As Worksheet
  Set d = CreateObject("scripting.dictionary")
  Application.DisplayAlerts = False
  For Each ws In Worksheets
    d(ws.Name) = ""
  Next
  arr = d.Keys
  For i = 0 To UBound(arr)
    With Worksheets(arr(i))
        .Select
        ActiveSheet.AutoFilterMode = False
       .Rows(1).Select
       Selection.AutoFilter
       A = .[A65000].End(3).Row
       B = .[IV1].End(xlToLeft).Column
       If .Cells(1, 4).Value = "分部" Then
        .Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=4, Criteria1:="=*武汉*"
       End If
       If .Cells(1, 8).Value = "分部" Then
         .Range(Cells(1, 1), Cells(A, B)).AutoFilter Field:=8, Criteria1:="=*武汉*"
       End If
      
       .Range(.Cells(1, 1), .Cells(A, B)).Select
       Selection.Copy
       Worksheets.Add After:=Worksheets(Worksheets.Count)
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
           :=False, Transpose:=False
       .Delete
     End With
   Next
End Sub