EXCEL常用VBA代码.docx
《EXCEL常用VBA代码.docx》由会员分享，可在线阅读，更多相关《EXCEL常用VBA代码.docx（10页珍藏版）》请在冰豆网上搜索。
EXCEL常用VBA代码
EXCEL常用VBA代码
删除B列中字符串数值少于21的单元格所在的行
Sub删除行（）
r=Range（"B65536"）.End（xlUp）.Row'行数
Forh=rTo1Step-1
IfCells（h,2）<21ThenCells（h,2）.EntireRow.Delete
Next
EndSub
-------------------------
【工作表合并】将同一工作簿中的所有工作表合并到一个工作表中
新建一个工作表，写入代码[在新建的工作表标签处右键查看代码（找不到的直接按一下alt+F11）把下面的代码复制进去然后点上面的运行运行子程序即可]：
Sub合并当前工作簿下的所有工作表（）
Application.ScreenUpdating=False
Forj=1ToSheets.Count
IfSheets（j）.Name<>ActiveSheet.NameThen
X=Range（"A65536"）.End（xlUp）.Row+1
Sheets（j）.UsedRange.CopyCells（X,1）
*****************
或者用以下宏代码
将同一工作簿中的所有工作表合并到一个新建的工作表中
按ALT+F11调出ＶＢＡ窗口，插入一个模块，然后把下面的代码复制进去。
Subhz（）
SetNewSheet=Sheets.Add（Type:
=xlWorksheet）'生成一个新表
Sheets（NewSheet.Index）.MoveBefore:
=Sheets
（1）'将此新表移动到最前面
Fori=2ToWorksheets.Count
Sheets（i）.UsedRange.CopyNewSheet.Cells（[a65536].End（xlUp）.Row+2,1）'将其他表的已使用区域复制到新表中
Nexti
MsgBox"合并完成"
EndSub
这段代码很简单，其中第四行中用FOR循环得到当前工作簿中的所有工作表，第五行中使用UsedRange得到每个工作表的“已使用区域”，然后用copy方法把这些“已使用区域”中的内容复制到新建工作表中。
语句Cells（[a65536].End（xlUp）.Row+2,1）的作用是得到新建工作表的Ａ列中的最后空白单元格（即要在哪个位置粘贴），加2的作用是使每次复制数据间隔2行空格（此处应表示间隔1行空格，加1的话，表示合并的表格与表格之间不留空格）。
回到EXCEL窗口，执行“工具-宏-宏”中的“hz”宏就会自动合并工作表了。
（经本人测试，不能使用右键点击标签查看代码再粘入代码的方式，应该运用菜单栏插入模块的方式）
---------------------------------------------------------------
【工作簿合并】
将需要合并的工作簿文件放置在一个文件夹中，并新建一个工作簿，写入代码：
Sub合并工作薄（）
DimFilesToOpen
DimxAsInteger
OnErrorGoToErrHandler
Application.ScreenUpdating=False
FilesToOpen=Application.GetOpenFilename_
（FileFilter:
="MicroSoftExcel文件（*.xls）,*.xls",_
MultiSelect:
=True,Title:
="要合并的文件"）
IfTypeName（FilesToOpen）="Boolean"Then
MsgBox"没有选中文件"
GoToExitHandler
EndIf
x=1
Whilex<=UBound（FilesToOpen）
Workbooks.OpenFilename:
=FilesToOpen（x）
Sheets（）.MoveAfter:
=ThisWorkbook.Sheets（ThisWorkbook.Sheets.Count）
x=x+1
Wend
ExitHandler:
Application.ScreenUpdating=True
ExitSub
ErrHandler:
MsgBoxErr.Description
ResumeExitHandler
EndSub
------------------------
显示隐藏的工作表
SubShowAllSheets（）'使当前工作簿中的所有工作表都显示（即将隐藏的工作表也显示）"
DimwsAsWorksheet
ForEachwsInSheets
ws.Visible=TrueNextws
EndSub
--------------------------------------------------------
根据Sheet2中的数据，检查Sheet1中的重复数据，并且进行后续的操作（将重复数据删除或者拷贝出来）的操作。
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
DimTo_be_deleted（5369）AsString
Forj=1To5368
To_be_deleted（j）=Trim（CStr（Sheets
（2）.Cells（j,2）.Value））
Nextj
Fori=1ToFirst_sheet_row
First_value=Trim（CStr（Sheets
（1）.Cells（i,C）.Value））
Forj=1To5368
'MsgBoxTo_be_deleted（j）
IfFirst_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）.PasteDestination:
=Sheets（3）.Range（"A"&i）
'Sheets（3）.Paste
Count=Count+1
i=i-1
EndIf
Nextj
Nexti
Application.ScreenUpdating=True
MsgBox"共删除了"&Count
这个脚本中有一些优化的地方，原来进行数据比较时，都是使用直接Cell（x,y）的方式访问并对比，另外也是分别循环，效率非常低，Excel一直处于假死的状态。
后来，先将比较小的一份数据拷贝到数组中，然后再进行循环，这样效率就提高了很多。
----------------------------------------------------------
合并目录中具有同样数据格式的多个Excel文件
DimMyPath,MyName,AWbName
DimWbAsWorkbook,WbNAsString
DimGAsLong
DimNumAsLong
DimBOXAsString
Application.ScreenUpdating=False
MyPath=ActiveWorkbook.Path
MyName=Dir（MyPath&"\"&"*.xls"）
AWbName=ActiveWorkbook.Name
Num=0
DoWhileMyName<>""
IfMyName<>AWbNameThen
SetWb=Workbooks.Open（MyPath&"\"&MyName）
Num=Num+1
WithWorkbooks
（1）.ActiveSheet
.Cells（.Range（"A65536"）.End（xlUp）.Row+2,1）=Left（MyName,Len（MyName）-4）
ForG=1ToSheets.Count
Wb.Sheets（G）.UsedRange.Copy.Cells（.Range（"A65536"）.End（xlUp）.Row+1,1）
Next
WbN=WbN&Chr（13）&Wb.Name
Wb.CloseFalse
EndWith
EndIf
MyName=Dir
Loop
Range（"A1"）.Select
Application.ScreenUpdating=True
MsgBox"共合并了"&Num&"个工作薄下的全部工作表。
如下：
"&Chr（13）&WbN,vbInformation,"提示"
-------------------------------------------------------------
奇偶页分别打印
Sub奇偶页分别打印（）
Dimi%,Ps%
Ps=ExecuteExcel4Macro（“GET.DOCUMENT（50）”）‘总页数
MsgBox“现在打印奇数页,按确定开始.”
Fori=1ToPsStep2
ActiveSheet.PrintOutfrom:
=i,To:
=i
Nexti
MsgBox“现在打印偶数页,按确定开始.”
Fori=2ToPsStep2
ActiveSheet.PrintOutfrom:
=i,To:
=i
Nexti
EndSub
--------------------------------------------------------
将A列最后数据行以上的所有B列图片大小调整为所在单元大小
Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小（）
DimPicAsPicture,i&
i=[A65536].End（xlUp）.Row
ForEachPicInSheet1.Pictures
IfNotApplication.Intersect（Pic.TopLeftCell,Range（“B1:
B”&i））IsNothingThen
Pic.Top=Pic.TopLeftCell.Top
Pic.Left=Pic.TopLeftCell.Left
Pic.Height=Pic.TopLeftCell.Height
Pic.Width=Pic.TopLeftCell.Width
EndIf
Next
EndSub
如何在原有行高的基础上增加一个固定值
PrivateSubCommandButton1_Click（）
Dimi,HangGao
Rows（"1:
100"）.EntireRow.AutoFit
HangGao=InputBox（"已设定自适应行高，设定想增加的行高","增加行高"）
Application.ScreenUpdating=False
Fori=1To100
Rows（i）.RowHeight=Rows（i）.RowHeight+CVar（HangGao）
Nexti
Application.ScreenUpdating=True
EndSub
代码的意思是：
选中前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,cell2）返回一个Range对象，其中cell1和cell2为指定起始和终止位置的Range对象。
下例设置单元格区域A1:
J10的边框线条的样式。
WithWorksheets⑴
.Range（.Cells（1,1），.Cells（10,10））.Borders.LineStyle=xlThick
EndWith
注意每个Cells属性之前的句点。
如果前导的With语句应用于该Cells属性，那么这些句点就是必需的。
本示例中，句点指示单元格处于第一张工作表上。
如果没有句点，Cells属性将返回活动工作表上的单元格。
4、Offset属性
可用Offset（row,column）（其中row和column为行偏移量和列偏移量）返回相对于另一区域在指定偏移量处的区域。
下例选定位于当前选定区域左上角单元格的向下三行且向右一列处的单元格。
由于必须选定位于活动工作表上的单元格，因此必须先激活工作表。
5、Union方法
可用Union（range1,range2,...）返回多块区域，即该区域由两个或多个连续的单元格区域所组成。
下例创建由单元格区域A1:
B2和C3:
D4组合定义的对象，然后选定该定义区域。
6、在VBA操作工作簿工作表时,会有很多刷新屏幕的动作,以致代码执行速度受到影响,Application.ScreenUpdating=False可以屏蔽屏幕刷新,进而提高运行速度，不过别忘了,在程序结尾添加恢复代码,即:
Application.ScreenUpdating=TRUE
Sheets（j）.Name--表（J）名称ActiveSheet.Name--活动表的名称）
升级会员 