几个有用的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, "提示"

 

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