几个有用的Excel VBA脚本

最近有个朋友要处理很多的Excel数据，但是手工处理又太慢，让我帮忙处理。通过搜索和自己的编写，帮他写了几个脚本，大大提高了工作效率。其实Excel中的脚本（宏）的功能非常方便，只要熟悉了Excel的对象，做一些常见的处理，还是非常容易的。

根据Sheet2中的数据，检查Sheet1中的重复数据，并且进行后续的操作（将重复数据删除或者拷贝出来）的操作。

'2010-12-22 使用Application.ScreenUpdating Application.ScreenUpdating = False C = 2       '第一个工作表检测B列 X = 1       '第一条检测结果放在第1行 Count = 1 First_sheet_row = Sheets(1).Cells(65536, C).End(xlUp).Row Second_sheet_row = Sheets(2).Cells(65536, C).End(xlUp).Row Dim To_be_deleted(5369) As String For j = 1 To 5368     To_be_deleted(j) = Trim(CStr(Sheets(2).Cells(j, 2).Value)) Next j For i = 1 To First_sheet_row     First_value = Trim(CStr(Sheets(1).Cells(i, C).Value))     For j = 1 To 5368         'MsgBox To_be_deleted(j)         If First_value = To_be_deleted(j) Then             Sheets(1).Range("A" & CStr(i) & ":Ag" & i).Delete             Sheets(2).Cells(j, 4).Value = "Copied"             'Sheets(2).Cells(j, 3).Value = "Copied"             'Application.CutCopyMode = False             'Sheets(1).Range("A" & CStr(i) & ":Ag" & i).Copy             'Sheets(3).Paste Destination:=Sheets(3).Range("A" & i)             'Sheets(3).Paste             Count = Count + 1             i = i - 1         End If     Next j Next i Application.ScreenUpdating = True MsgBox "共删除了" & Count

这个脚本中有一些优化的地方，原来进行数据比较时，都是使用直接Cell(x,y)的方式访问并对比，另外也是分别循环，效率非常低，Excel一直处于假死的状态。

后来，先将比较小的一份数据拷贝到数组中，然后再进行循环，这样效率就提高了很多。

合并目录中具有同样数据格式的多个Excel文件

Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False MyPath = ActiveWorkbook.Path MyName = Dir(MyPath & "\" & "*.xls") AWbName = ActiveWorkbook.Name Num = 0 Do While MyName <> "" If MyName <> AWbName Then Set Wb = Workbooks.Open(MyPath & "\" & MyName) Num = Num + 1 With Workbooks(1).ActiveSheet .Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 To Sheets.Count Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1) Next WbN = WbN & Chr(13) & Wb.Name Wb.Close False End With End If MyName = Dir Loop Range("A1").Select Application.ScreenUpdating = True MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"

合并一个文件中的多个Sheet

Application.ScreenUpdating = False For j = 1 To Sheets.Count     If Sheets(j).Name <> ActiveSheet.Name Then         X = Range("A65536").End(xlUp).Row + 1         Sheets(j).UsedRange.Copy Cells(X, 1)     End If Next Range("A1").Select Application.ScreenUpdating = True MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"

利用编程，可以让我们的生活更美好~~