[已解决]代码提示下标越界，拜托老师们指出错误，O(∩_∩)O谢谢

长夜多浪漫

目的是从第一列中把包含工作表名称的内容筛选出来并删除！代码如下，附件如下、、、、错误可能比较多，劳烦各位指导！        Private Sub CommandButton1_Click()    Dim arr, brr()
    Dim n, i, sh As Worksheet
     Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    arr = Sheet1.[a1].CurrentRegion
     For Each sh In Worksheets
    For i = 2 To UBound(arr)
        If arr(i, 1) = "*" & sh.Name & "*" Then
            n = n + 1
            ReDim Preserve brr(1 To 4, 1 To n)
            brr(1, n) = arr(i, 1)
            brr(2, n) = arr(i, 2)
            brr(3, n) = arr(i, 3)
            brr(4, n) = arr(i, 4)
            Sheet1.Rows(i).Delete
        End If
    Next i
  Next
    sh.Range("A2").Resize(UBound(brr, 2), 4) = Application.Transpose(brr)
   sh.[a1:d4] = Array(Array("关键词", "消费", "点击量", "展现量"))
    Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

最佳答案

月排行榜 / 总排行榜

fffox

2014-7-11 11:28

1. Sub test()
   
2.     Dim arr, brr(), crr(), i%, j%, k%, str$, x%, sht As Worksheet
   
3.     arr = ActiveSheet.Range("a1").CurrentRegion.Value
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For Each sht In Worksheets
   
7.         If sht.Name <> ActiveSheet.Name Then
   
8.             str = sht.Name
   
9.             crr(1, 1) = "关键词": crr(1, 2) = "消费"
   
10.             crr(1, 3) = "点击量": crr(1, 4) = "展现量"
    
11.             k = 1
    
12.             For i = 2 To UBound(arr)
    
13.                 If arr(i, 1) Like "*" & str & "*" Then
    
14.                     k = k + 1
    
15.                     For j = 1 To 4
    
16.                         crr(k, j) = arr(i, j)
    
17.                     Next
    
18.                     arr(i, 1) = ""
    
19.                 End If
    
20.             Next
    
21.             If k > 1 Then sht.Range("a1").Resize(k, 4) = crr
    
22.         End If
    
23.     Next
    
24.     k = 0
    
25.     For i = 1 To UBound(arr)
    
26.         If arr(i, 1) <> "" Then
    
27.             k = k + 1
    
28.             For j = 1 To UBound(arr, 2)
    
29.                 brr(k, j) = arr(i, j)
    
30.             Next
    
31.         End If
    
32.     Next
    
33.     With ActiveSheet.Range("a1").CurrentRegion
    
34.         .ClearContents
    
35.         .Resize(k, UBound(arr, 2)) = brr
    
36.     End With
    
37. End Sub

复制代码

跳转到最佳答案楼层

长夜多浪漫

  系统提示 ：运行时错误 ”5“  无效的过程调用或参数！！

hwc2ycy

凡是有宏代码的工作簿在07或10下请保存为XLS或XLSM格式，否则代码会丢失。

长夜多浪漫

hwc2ycy 发表于 2014-7-10 17:42
凡是有宏代码的工作簿在07或10下请保存为XLS或XLSM格式，否则代码会丢失。

帮忙指导下 哪里出现错误了

ghostjiao

1. Option Explicit
   
2. Sub CommandButton1_Click()
   
3.     Dim arr, brr()
   
4.     Dim n, i, sh As Worksheet
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     arr = Sheet1.[a1].CurrentRegion
   
8.     For Each sh In Worksheets
   
9.         If sh.Name <> "Sheet1" Then
   
10.             For i = 2 To UBound(arr)
    
11.                 If InStr(arr(i, 1), sh.Name) Then
    
12.                     n = n + 1
    
13.                     ReDim Preserve brr(1 To 4, 1 To n)
    
14.                     brr(1, n) = arr(i, 1)
    
15.                     brr(2, n) = arr(i, 2)
    
16.                     brr(3, n) = arr(i, 3)
    
17.                     brr(4, n) = arr(i, 4)
    
18.                     Sheet1.Rows(i).Delete
    
19.                 End If
    
20.             Next i
    
21.             If n > 0 Then
    
22.                 sh.Range("A2").Resize(UBound(brr, 2), 4) = Application.Transpose(brr)
    
23.                 sh.[a1:d1] = Array("关键词", "消费", "点击量", "展现量")
    
24.                 Erase brr
    
25.                 n = 0
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     Application.ScreenUpdating = True
    
30.     Application.DisplayAlerts = True
    
31. End Sub
    

复制代码

你也没说具体怎么判断，有些词出现多个表名

su45

你的附件没有按钮，也没窗体，更没说明问题！

长夜多浪漫

ghostjiao 发表于 2014-7-10 18:11
你也没说具体怎么判断，有些词出现多个表名

感谢您的回复，判断就是 如果工作表名称是什么，比如工作表名称是“皮肤”，那么就从第一列中把包含皮肤的行筛选出来，放到“皮肤”工作表内，并把筛选出来的数据从原始数据中删除掉。

长夜多浪漫

su45 发表于 2014-7-10 21:25
你的附件没有按钮，也没窗体，更没说明问题！

感谢您的回复，判断就是 如果工作表名称是什么，比如工作表名称是“皮肤”，那么就从第一列中把包含皮肤的行筛选出来，放到“皮肤”工作表内，并把筛选出来的数据从原始数据中删除掉。附件只是数据的格式，代码我已经写在论坛里了，运行时出现错误，就是想请你们帮我看看究竟哪里错了？

长夜多浪漫

ghostjiao 发表于 2014-7-10 18:11
你也没说具体怎么判断，有些词出现多个表名

老师您好，我刚试了下代码  可以把符合条件的筛选出来，但就是原数据里如果有重复的妾符合条件的，它只能删除一条，不能删除全部

fffox

1. Sub test()
   
2.     Dim arr, brr(), crr(), i%, j%, k%, str$, x%, sht As Worksheet
   
3.     arr = ActiveSheet.Range("a1").CurrentRegion.Value
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For Each sht In Worksheets
   
7.         If sht.Name <> ActiveSheet.Name Then
   
8.             str = sht.Name
   
9.             crr(1, 1) = "关键词": crr(1, 2) = "消费"
   
10.             crr(1, 3) = "点击量": crr(1, 4) = "展现量"
    
11.             k = 1
    
12.             For i = 2 To UBound(arr)
    
13.                 If arr(i, 1) Like "*" & str & "*" Then
    
14.                     k = k + 1
    
15.                     For j = 1 To 4
    
16.                         crr(k, j) = arr(i, j)
    
17.                     Next
    
18.                     arr(i, 1) = ""
    
19.                 End If
    
20.             Next
    
21.             If k > 1 Then sht.Range("a1").Resize(k, 4) = crr
    
22.         End If
    
23.     Next
    
24.     k = 0
    
25.     For i = 1 To UBound(arr)
    
26.         If arr(i, 1) <> "" Then
    
27.             k = k + 1
    
28.             For j = 1 To UBound(arr, 2)
    
29.                 brr(k, j) = arr(i, j)
    
30.             Next
    
31.         End If
    
32.     Next
    
33.     With ActiveSheet.Range("a1").CurrentRegion
    
34.         .ClearContents
    
35.         .Resize(k, UBound(arr, 2)) = brr
    
36.     End With
    
37. End Sub

复制代码