[已解决]抽取多工作表数据的问题

hwc2ycy

略微改下，先清除工作表原有数据。

1. Sub test()
   
2.     Dim arr, arrResult
   
3.     Dim i As Integer, j As Long
   
4.     Dim objSht As Worksheet
   
5.     Dim lRecord As Long
   
6.     Dim lMatch
   
7. 
   
8. 
   
9.     '引用写入工作表
   
10.     Set objSht = Worksheets("sheet0")
    
11. 
    
12.     '清除原有数据
    
13.     With objSht
    
14.         .UsedRange.ClearContents
    
15.     End With
    
16. 
    
17.     lMatch = Application.InputBox("请输入要匹配的数值", "匹配查找", 92, , , , , 1)
    
18.     If lMatch = False Then
    
19.         MsgBox "没有输入要匹配的数值" & "退出", vbCritical + vbOKOnly
    
20.         Exit Sub
    
21.     End If
    
22. 
    
23.     '关属性
    
24.     With Application
    
25.         .ScreenUpdating = False
    
26.         .DisplayAlerts = False
    
27.         .EnableEvents = False
    
28.         .Calculation = xlCalculationManual
    
29.     End With
    
30. 
    
31.     '工作表循环
    
32.     For i = 1 To Worksheets.Count - 1
    
33.         On Error Resume Next
    
34.         '防止访问到不存在的工作表
    
35.         If Len(Worksheets(CStr(i)).Name) = 0 Then
    
36.             GoTo next1
    
37.         End If
    
38. 
    
39.         On Error GoTo ErrorHandler
    
40.         '取源数据的D-F列
    
41.         With Worksheets(CStr(i))
    
42.             arr = .UsedRange.Columns("d:f").Value
    
43.         End With
    
44.         '重定义数组，和源数据数组行数相同
    
45.         ReDim arrResult(1 To UBound(arr), 1 To 1)
    
46.         '当前数组内写入数据个数
    
47.         lRecord = 0
    
48.         For j = LBound(arr) To UBound(arr)
    
49.             '进行匹配，符合条件的写入数组内
    
50.             'Debug.Assert arr(j, 3) <> lMatch
    
51.             If arr(j, 3) = lMatch Then
    
52.                 lRecord = lRecord + 1
    
53.                 arrResult(lRecord, 1) = arr(j, 1)
    
54.             End If
    
55.         Next
    
56. 
    
57.         With objSht
    
58.             '有符合要求的数据时，进行写入操作
    
59.             If lRecord Then
    
60.                 .Cells(1, i).Resize(UBound(arrResult)).Value = arrResult
    
61.             End If
    
62.         End With
    
63. next1:
    
64.     Next
    
65.     '释放对象变量
    
66.     Set objSht = Nothing
    
67.     '打开属性
    
68.     With Application
    
69.         .ScreenUpdating = True
    
70.         .DisplayAlerts = True
    
71.         .EnableEvents = True
    
72.         .Calculation = xlCalculationAutomatic
    
73.     End With
    
74.     '对话框提示完成
    
75.     MsgBox "提取完成"
    
76.     Exit Sub
    
77. ErrorHandler:
    
78.     '错误处理，主要是针对数据无法写入工作表的情况
    
79.     MsgBox Err.Number & vbCrLf & _
    
80.            Err.Description
    
81.     Err.Clear
    
82.     '开属性
    
83.     With Application
    
84.         .ScreenUpdating = True
    
85.         .DisplayAlerts = True
    
86.         .EnableEvents = True
    
87.         .Calculation = xlCalculationAutomatic
    
88.     End With
    
89. End Sub

复制代码

hwc2ycy

抽取多工作表数据附件.rar (359.94 KB, 下载次数: 8)

2013-6-25 08:34 上传

点击文件名下载附件

huangjjj

hwc2ycy 发表于 2013-6-25 08:34

谢谢老师帮助。