FileSearch/Workbook/Dictionary对象举例
目前为止,发现了几个在处理数据时非常有用的对象,分别是:Workbook对象/FileSearch对象/Dictionary对象/Range对象
其中Range对象不用说,在遍历单元格时特别有用,而且速度超快,基本用法就是For each………in………
Workbook对象在需要从工作簿中读取数据(但不写入)时,非常有用,用此对象可以不用打开源工作簿,从而可以大大节省时间.
FileSearch对象在需要大批量读取文件名,尤其是不知道有多少个文件名,比如在处理学生单个评语文件时(*.doc或*.xls)特别有用,利用它可以搜索指定文件夹下的特定条件,然后可以实现大批量读写.
关于Workbook对象及FileSearch对象用下面的例子加以说明:
Sub 如何将多个工作簿中格式一致的工作表数据合并到同一工作簿中()
'首先获得需要合并的工作簿文件名
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Dim i As Integer, xls() As String
Dim sr As FileSearch '定义一个文件搜索对象
Set sr = Application.FileSearch
sr.LookIn = "E:胶州一中" '注意路径，换成你实际的路径
sr.Filename = "xx*.xls" '搜索所有文件
sr.Execute '执行搜索
ReDim xls(sr.FoundFiles.Count)
For i = 1 To sr.FoundFiles.Count
xls(i) = sr.FoundFiles(i) '因为下面需要打开指定路径下的文件,故就不需再去掉路径名了,直接将完整路径输入即可.
Debug.Print xls(i)
Next
'设置一个工作簿对象,获取各学段各学科的学分数据并将其复制到同一工作簿中
Dim wb As Workbook, j As Integer, TotalR As Integer
Debug.Print ActiveWorkbook.Name
For i = 1 To sr.FoundFiles.Count
TotalR = Range("A65536").End(xlUp).Row
Set wb = GetObject(xls(i))
With wb.Sheets(1)
.Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column)).Copy
End With
Range(Cells(TotalR + 1, 1), Cells(TotalR + 1, 1)).PasteSpecial xlPasteAll'默认值
Range(Cells(TotalR + 1, 1), Cells(TotalR + 1, 1)).PasteSpecial xlPasteValues'只复制数值,尤其是在带公式运算时,特别有用.
TotalR = Range("A65536").End(xlUp).Row
Debug.Print TotalR
Application.CutCopyMode = False
wb.Close savechanges:=False
Next i
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = True
Cells.Font.Name = "微软雅黑"
Cells.Font.Size = 10
Cells.Columns.AutoFit
Cells.HorizontalAlignment = True
End Sub
关于Dictionnary对象的用法,想用下面的例子说明,其中已经融入了关于多维数组的用法,并且成功突破了当时ExelHome给出的用法的限制.心里有点窃喜啊!!
Option Base 1
Sub 导入文科原始成绩()
Application.ScreenUpdating = False
Dim i As Integer, j As Integer, TotalR As Integer, k As Integer
Dim km(6) As String
km(1) = "语文"
km(2) = "数学"
km(3) = "外语"
km(4) = "政治"
km(5) = "历史"
km(6) = "地理"
'转入正式程序设计
Dim dic As Object, wb As Object
Dim arr()
Dim arr1()
For i = 1 To 6
For j = 1 To 2
Set wb = GetObject(ThisWorkbook.Path & "" & km(i) & Trim(Str(j) & ".xls")) '创建一个工作簿对象,这样可不用再打开各科工作簿了,明显的节省时间.
'Debug.Print wb.Name
TotalR = wb.Sheets(1).Range("A65536").End(xlUp).Row '取得wb工作簿对象的行数,这种方式只适合于读取数据,不能写入数据,要想写入数据,必须将对应工作簿实际打开才可.此处若不加wb则默认为代码所在工作簿了,所以务必要加.
arr = wb.Sheets(1).Range("A1").Resize(TotalR, 2).Value '生成了一个totalR行,2列的一个二维数组.这种用法要逐步习惯!!
wb.Close False '给数组赋值结束后,及时将工作簿对象关闭,以节省内存,提高效率.
Set dic = CreateObject("scripting.dictionary") '创建字典
For k = 2 To UBound(arr)
dic(arr(k, 1)) = arr(k, 2) '以arr(k,1)即考试号为关键字,arr(k,2)为条目
'Debug.Print arr(k, 2)
Next k
Erase arr '创建完字典,由于arr数组原有内容已无用处,及时清掉,为下面的应用做准备.
Sheets(1).Activate '激活需要填入成绩的工作表,其实不用激活也可以.
TotalR = Range("A65536").End(xlUp).Row '取得当前工作表的行数
arr = Range("A1").Resize(TotalR, Range("IV2").End(xlToLeft).Column + 1).Value '创建一个totalR行,Range("IV2").End(xlToLeft).Column + 1列的多维数组,数组最多不能超过60维!
For k = 1 To UBound(arr) '由于字典中的关键字(考试号)对应着arr数组中的第1列,故可以按关键字将对应条目(单科成绩)赋值给arr数组的第Range("IV2").End(xlToLeft).Column + 1列.
arr(k, Range("IV2").End(xlToLeft).Column + 1) = dic(arr(k, 1))
'Debug.Print arr(k, Range("IV2").End(xlToLeft).Column + 1)
Next k
'利用index工作表函数将arr数组里的第Range("IV2").End(xlToLeft).Column + 1列的值赋给相应单元格,由于arr数组就是从工作表中取得的,所以肯定是一一对应的.所以直接赋值即可.
Cells(1, Range("IV2").End(xlToLeft).Column + 1).Resize(TotalR, 1).Value = Application.WorksheetFunction.Index(arr, 0, Range("IV2").End(xlToLeft).Column + 1)
'以下注释行一样可以实现相同的效果,只是不如上面这一句显得简洁,
' 'Debug.Print Format(UBound(arr))
' ReDim arr1(UBound(arr))
' Range("A1").Resize(Range("A65536").End(3).Row, Range("IV2").End(xlToLeft).Column + 1).NumberFormatLocal = "@"
' For k = 1 To UBound(arr)
' arr1(k) = arr(k, Range("IV2").End(xlToLeft).Column + 1) '将多维数组中的成绩维转换成一维数组
' 'Debug.Print arr1(k)
' Next k
' '以下三行一样可以实现!!现在有三种方式可以应用,这是第一次啊.
'' For k = 1 To UBound(arr1)
'' Cells(k, Range("IV" & Trim(Str(k))).End(xlToLeft).Column + 1).Value = arr1(k)
'' Next k
' Cells(1, Range("IV2").End(xlToLeft).Column + 1).Resize(TotalR, 1).Value = Application.WorksheetFunction.Transpose(arr1)
' Erase arr1
'赋完值及时将arr清空,以便于下次循环使用.
Erase arr
Next j
Next i
'最后添加表头,很好,明白什么意思了.
For i = 1 To 6
For j = 1 To 2
Cells(1, Range("IV1").End(xlToLeft).Column + 1).Value = km(i) & Trim(Str(j))
Next j
Next i
Application.ScreenUpdating = True
End Sub
关于字典关键字及条目的获取,应该也可以用循环获取得:
Sub 关于创建字典的第2种方式()
Dim TotalR As Integer, dic As Object, i As Integer
Dim dica
TotalR = Range("A65536").End(xlUp).Row
Set dic = CreateObject("scripting.dictionary")
'以下注释行一样运行,下面的正式行也是验证.
' For i = 2 To TotalR
' If Not dic.exists(Cells(i, 1).Value) Then
' dic.Add Cells(i, 1).Value, Cells(i, 2).Value
' End If
' Next i
' dica = dic.keys
' Debug.Print dica(0) '该处为什么会运行呢?前面已经加了Option Base 1
' Range("O2").Resize(dic.Count + 1, 1).NumberFormatLocal = "@"
' Range("O2").Resize(dic.Count + 1, 1).Value = Application.WorksheetFunction.Transpose(dic.keys)
' dic.RemoveAll
dica = Range("A2").Resize(TotalR - 1, 2).Value'实际上定义了一个二维数组.
For i = 1 To UBound(dica)
dic(dica(i, 1)) = dica(i, 2)
Next i
Erase dica
dica = dic.keys '字典创建的数组从0开始,不受option base 1的限制.
Debug.Print dic.Count
' For i = 0 To dic.Count - 1
' Debug.Print dica(i)
' Next i
End Sub
对于字典掌握了吗?差不多吧,但是常言说的好,做永远比看要好!!还是要多实践.
今天你菊子曰了么？