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

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

几个有用的Excel VBA脚本

cocowool

友情链接