编写简单VBA做excel统计

上周末，一个朋友加班到很晚，说是做一些繁琐的工作焦头烂额，根据多个excel文件数据并做更新，我寻思着，给你写个按钮吧，可能会省你不少事，于是，写了个简单的VBA，一定按钮便能自动更新数据，省得一条条比对了。由于本人环境是繁体，移到简体环境上中文注释出现乱码，省略掉一些注释，下面记下部分代码（具体数据更新方式省略，改为简单数据更新，以减少代码的长度），方便以后查找。

View Code

 1 Sub updatedata()
 2 Dim strPath, strfile As String
 3 Dim r As Variant, i, j As Integer
 4 Dim a, b As Integer
 5 Dim arr(1 To 27, 1 To 30)
 6 
 7 With Application.FileSearch
 8 .FileType = msoFileTypeExcelWorkbooks
 9 .LookIn = "C:\Documents and Settings\leo jiang\"
10 .SearchSubFolders = False
11 .Execute
12 
13 strPath = "C:\Documents and Settings\leo jiang\ "                            
14 
15 Cells(1, 1) = ""
16 m = .FoundFiles.Count 
17 i = 1
18      For a = 1 To 5                                             
19             For b = 1 To 5
20                arr(a, b) = 0
21             Next
22       Next
23          
24 For Each F In .FoundFiles 
25          For a = 7 To 9                                              '获取资料
26              For b = 1 To 5
27                    
28               r = GetValue(strPath, Dir(F), "Sheet2", Cells(a + 2, b + 1).Address(0, 0))
29             
30               arr(a, b) = arr(a, b) + r
31    
32              Next
33         Next
34         Cells(1, 1) = "共有" & m & "分文档，现在更新到第" & i & "份"
35     i = i + 1
36 Next
37 End With
38 
39 With Sheets(2)
40 For a = 1 To 25                                               '写数据
41     For b = 1 To 25
42             Cells(a + 2, b + 1) = arr(a, b)
43     Next
44 Next
45 End With
46 
47 End Sub
48 
49 
50 
51 Private Function GetValue(path, file, sheet, range_ref)
52     Dim arg As String
53     If Right(path, 1) <> "\" Then path = path & "\"
54     If Dir(path & file) = "" Then
55         GetValue = "File Not Found"
56         Exit Function
57     End If
58     arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
59     Range(range_ref).Range("A1").Address(, , xlR1C1)                 
60     GetValue = ExecuteExcel4Macro(arg)
61 End Function

转载于:https://www.cnblogs.com/haitunzhilian/archive/2011/11/23/2259745.html