[已解决]查找特定内容并复制到另外的表中

fengdavid

想用VBA提高工作效率。从1、2、3班的成绩表中查找英语缺考的学生，并把该学生所有的成绩复制到英语缺考统计表中，同时序号列从1开始自动编号。有几个英语缺考的学生就编到几， 查找特定内容并复制到另外的表中.rar (24.61 KB, 下载次数: 3)

2013-12-18 20:54 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-12-18 21:30

请测试：
查找特定内容并复制到另外的表中.zip (23.6 KB, 下载次数: 13)

2013-12-18 21:30 上传

点击文件名下载附件

1. Sub 缺考()
   
2. Dim arr, brr(1 To 100000, 1 To 5), sh As Worksheet, mypath$, myname$, i&, j&, k&
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. myname = Dir(mypath & "*.xls*")
   
7. Do While myname <> ""
   
8.    If myname <> ThisWorkbook.Name Then
   
9.       With Workbooks.Open(mypath & myname)
   
10.            arr = .Sheets(1).[a1].CurrentRegion
    
11.            For i = 2 To UBound(arr)
    
12.                If arr(i, 4) = "缺考" Then
    
13.                   k = k + 1
    
14.                   brr(k, 1) = k
    
15.                   brr(k, 2) = arr(i, 1)
    
16.                   brr(k, 3) = arr(i, 2)
    
17.                   brr(k, 4) = arr(i, 3)
    
18.                   brr(k, 5) = arr(i, 4)
    
19.                End If
    
20.            Next i
    
21.            .Close False
    
22.       End With
    
23.     End If
    
24.     myname = Dir
    
25.     Erase arr
    
26. Loop
    
27.     If k > 0 Then
    
28.         ThisWorkbook.Sheets(1).Range("a2").Resize(k + 2, 5 + 1) = ""
    
29.         ThisWorkbook.Sheets(1).Range("a2").Resize(k, 5) = brr
    
30.     Else
    
31.        MsgBox "没有英语缺考的学生"
    
32.     End If
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

跳转到最佳答案楼层

yyyydddd8888

请测试：
查找特定内容并复制到另外的表中.zip (23.6 KB, 下载次数: 13)

2013-12-18 21:30 上传

点击文件名下载附件

1. Sub 缺考()
   
2. Dim arr, brr(1 To 100000, 1 To 5), sh As Worksheet, mypath$, myname$, i&, j&, k&
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. mypath = ThisWorkbook.Path & ""
   
6. myname = Dir(mypath & "*.xls*")
   
7. Do While myname <> ""
   
8.    If myname <> ThisWorkbook.Name Then
   
9.       With Workbooks.Open(mypath & myname)
   
10.            arr = .Sheets(1).[a1].CurrentRegion
    
11.            For i = 2 To UBound(arr)
    
12.                If arr(i, 4) = "缺考" Then
    
13.                   k = k + 1
    
14.                   brr(k, 1) = k
    
15.                   brr(k, 2) = arr(i, 1)
    
16.                   brr(k, 3) = arr(i, 2)
    
17.                   brr(k, 4) = arr(i, 3)
    
18.                   brr(k, 5) = arr(i, 4)
    
19.                End If
    
20.            Next i
    
21.            .Close False
    
22.       End With
    
23.     End If
    
24.     myname = Dir
    
25.     Erase arr
    
26. Loop
    
27.     If k > 0 Then
    
28.         ThisWorkbook.Sheets(1).Range("a2").Resize(k + 2, 5 + 1) = ""
    
29.         ThisWorkbook.Sheets(1).Range("a2").Resize(k, 5) = brr
    
30.     Else
    
31.        MsgBox "没有英语缺考的学生"
    
32.     End If
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

fengdavid

yyyydddd8888 发表于 2013-12-18 21:30
请测试：

运行时错误13，类型不匹配。Erase arr
注释掉后可以使用

yyyydddd8888

fengdavid 发表于 2013-12-18 21:40
运行时错误13，类型不匹配。Erase arr
注释掉后可以使用

如果可以用就请给个最佳。