EXCEL常用VBA代码

1、删除B列中字符串数值少于21的单元格所在的行Sub 删除行()r = Range("B65536").End(xlUp).Row '行数For h = r To 1 Step -1 If Cells(h, 2) < 21 Then Cells(h, 2).EntireRow.Delete NextEnd Sub -【工作表合并】将同一工作簿中的所有工作表合并到一个工作表中新建一个工作表，写入代码在新建的工作表标签处右键 查看代码（找不到的直接按一下alt+F11) 把下面 的代码复制进去 然后点上面的运行 运行子程序即可：Sub 合并当前工作簿下的所有工作表(

2、)Application.ScreenUpdating = FalseFor 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 IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "当前工作簿下的全部工作表已经合并完毕！&q

3、uot;, vbInformation, "提示"End Sub*代码这样写也行：Sub c()For i = Sheets.Count To 2 Step -1Sheets(i).SelectSheets(i).UsedRange.CopySheets(1).SelectCells(Cells(65000, 1).End(xlUp).Row + 1, 1).SelectActiveSheet.Paste'Sheets(i).DeleteNext iEnd Sub*把一个工作簿中的所有表单合并成一个表单，怎么去掉重复的表头、标题行？方法如下：Sub c()For i

4、 = Sheets.Count To 2 Step -1Sheets(i).UsedRange.Offset(1).Copy Sheets(1).Cells(65536, 1).End(xlUp).Offset(1)Next iEnd Sub说明：函数OFFSET(reference,rows,cols,height,width)以指定的引用为参照系，通过给定偏移量得到新的引用。返回的引用可以为一个单元格或单元格区域。并可以指定返回的行数或列数。通俗的讲就是OFFSET(参考单元格，移动的行数，移动的列数，所要引用的行数，所要引用的列数） 参考关于offset函数第三行中第一个offset(1

5、)是假设要要去掉的表头行数，如果有2行表头，就改成offset(2)，要去掉几行表头括号中的数字就改成几。第二个offset(1)表示合并以后表格与表格之间要间隔的空行，offset(1)表示不留空行，offset(2)表示间隔1行空行，以此类推。也可以这样写：Sub c()For i = Sheets.Count To 2 Step -1Sheets(i).UsedRange.Offset(2).Copy Sheets(1).Cells(Cells(65536, 1).End(xlUp).Row + 1, 1).Offset(0) 这个offset(0)可以不要Next iEnd Sub*或

6、者用以下宏代码将同一工作簿中的所有工作表合并到一个新建的工作表中按ALT+F11调出窗口，插入一个模块，然后把下面的代码复制进去。Sub hz() Set NewSheet = Sheets.Add(Type:=xlWorksheet) '生成一个新表 Sheets(NewSheet.Index).Move Before:=Sheets(1) '将此新表移动到最前面 For i = 2 To Worksheets.Count Sheets(i).UsedRange.Copy NewSheet.Cells(a65536.End(xlUp).Row + 2, 1) '将其他

7、表的已使用区域复制到新表中 Next i MsgBox "合并完成"End Sub这段代码很简单，其中第四行中用FOR循环得到当前工作簿中的所有工作表，第五行中使用UsedRange得到每个工作表的“已使用区域”，然后用copy方法把这些“已使用区域”中的内容复制到新建工作表中。语句Cells(a65536.End(xlUp).Row + 2, 1)的作用是得到新建工作表的列中的最后空白单元格(即要在哪个位置粘贴)，加2的作用是使每次复制数据间隔2行空格（此处应表示间隔1行空格，加1的话，表示合并的表格与表格之间不留空格）。回到EXCEL窗口，执行“工具-宏-宏”中的“hz

8、”宏就会自动合并工作表了。（经本人测试，不能使用右键点击标签查看代码再粘入代码的方式，应该运用菜单栏插入模块的方式）-【工作簿合并】将需要合并的工作簿文件放置在一个文件夹中，并新建一个工作簿，写入代码：Sub 合并工作薄()Dim FilesToOpenDim x As IntegerOn Error GoTo ErrHandlerApplication.ScreenUpdating = FalseFilesToOpen = Application.GetOpenFilename _(FileFilter:="MicroSoft Excel文件(*.xls), *.xls"

9、, _MultiSelect:=True, Title:="要合并的文件")If TypeName(FilesToOpen) = "Boolean" ThenMsgBox "没有选中文件"GoTo ExitHandlerEnd Ifx = 1While x <= UBound(FilesToOpen)Workbooks.Open Filename:=FilesToOpen(x)Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)x = x + 1W

10、endExitHandler:Application.ScreenUpdating = TrueExit SubErrHandler:MsgBox Err.DescriptionResume ExitHandlerEnd Sub-显示隐藏的工作表Sub ShowAllSheets() '使当前工作簿中的所有工作表都显示(即将隐藏的工作表也显示)" Dim ws As Worksheet For Each ws In Sheets ws.Visible = True Next wsEnd Sub-根据Sheet2中的数据，检查Sheet1中的重复数据，并且进行后续的操作（将重复

11、数据删除或者拷贝出来）的操作。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(C

12、Str(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).

13、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(

14、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

15、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 <>

16、 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").En

17、d(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, "提示" -奇

18、偶页分别打印 Sub 奇偶页分别打印() Dim i%, Ps% Ps = ExecuteExcel4Macro(“GET.DOCUMENT(50)”) 总页数 MsgBox “现在打印奇数页,按确定开始.” For i = 1 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=i Next i MsgBox “现在打印偶数页,按确定开始.” For i = 2 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=i Next i End Sub -将A列最后数据行以上的所有B列图片大小调整为所在单元大小 S

19、ub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小() Dim Pic As Picture, i& i = A65536.End(xlUp).Row For Each Pic In Sheet1.Pictures If Not Application.Intersect(Pic.TopLeftCell, Range(“B1:B” & i) Is Nothing Then Pic.Top = Pic.TopLeftCell.Top Pic.Left = Pic.TopLeftCell.Left Pic.Height = Pic.TopLeftCell.Height

20、Pic.Width = Pic.TopLeftCell.Width End If Next End Sub 如何在原有行高的基础上增加一个固定值 Private Sub CommandButton1_Click() Dim i, HangGao Rows("1:100").EntireRow.AutoFit HangGao = InputBox("已设定自适应行高，设定想增加的行高", "增加行高") Application.ScreenUpdating = False For i = 1 To 100 Rows(i).RowHeig

21、ht = Rows(i).RowHeight + CVar(HangGao) Next i Application.ScreenUpdating = TrueEnd Sub代码的意思是：选中前100行，然后自动根据内容调整到合适的行高，就跟你选中以后双击黑线是一样的效果。然后在弹出的对话框中输入你想要每行增加行高的数值，比如说输入23，每个行高就加23.-其他解释：Range是区域，范围的意思range("A1")对一个单元格集合进行范围筛选(只选中最左上角的1个单元格)，比如 sheet1.range("A1:C3").select将选中sheet1的左上角的9个单元格选中。1、Range 属性Range(arg)（其中 arg 为区域名称）来返回代表单个单元格或单元格区域的 Range 对象 2、Cells 属性可用 Cells(row,column）（其中 row 为行号，column 为列标）返回单个单元格3、Range 和 Cells可用 Range(cell1,cel