宏命令语句.docx
《宏命令语句.docx》由会员分享，可在线阅读，更多相关《宏命令语句.docx（16页珍藏版）》请在冰豆网上搜索。
宏命令语句
PrivateDeclareSubSleepLib"kernel32"（ByValdwMillisecondsAsLong）
OptionExplicit
SubMacro1（）
DimlineProgramRangeAsRange'单行程序代码范围
DimselRgeAsRange
DimiAsLong
DimnumAsLong
'Macro1Macro
'宏在2013-4-17由许长安录制
DimparaNum
',iAsInteger
paraNum=ActiveDocument.Paragraphs.Count
'Selection.MoveDownUnit:
=wdLine,Count:
=1
'SetselRge=Selection.Range
MsgBox"Theselectionisonpage"&_
Selection.Information（wdActiveEndPageNumber）&";Column"_
&Selection.Information（wdFirstCharacterColumnNumber）&_
";Line"_
&Selection.Information（wdFirstCharacterLineNumber）&_
";总行数:
"_
&ActiveDocument.Paragraphs.Count
'num=Selection.Information（wdFirstCharacterLineNumber）
DimmyColorAsLong
myColor=ActiveDocument.Background.Fill.ForeColor.RGB
MsgBoxGetColor（myColor）
Fornum=Selection.Information（wdFirstCharacterLineNumber）ToparaNum
Selection.MoveDownUnit:
=wdLine,Count:
=1
Selection.HomeKeyUnit:
=wdLine'光标回到行首
Selection.EndKeyUnit:
=wdLine,Extend:
=wdExtend'选中整行
'Selection.MoveDownUnit:
=wdLine,Count:
=1,Extend:
=wdExtend
Options.DefaultHighlightColorIndex=wdRed
Selection.Range.HighlightColorIndex=wdRed
Sleep100
'Selection.MoveUpUnit:
=wdLine,Count:
=1,Extend:
=wdExtend
Options.DefaultHighlightColorIndex=wdNoHighlight
Selection.Range.HighlightColorIndex=wdNoHighlight
MsgBox";总行数"&num
'得到当前选中行并设置颜色为蓝色
'SetlineProgramRange=selRge.Paragraphs（i）.Range
'Paragraphs（Selection.Information（wdFirstCharacterLineNumber））.Range
'Selection.Font.ColorIndex=wdBlue
'lineProgramRange.Font.ColorIndex=wdBlue
'selRge.Paragraphs（nLineNum）.Range.InsertBefore（sLineNum）
Nextnum
EndSub
FunctionGetColor（ColorAsLong）AsString
SelectCaseColor
CaseIs=-16777216
GetColor="自动色"
CaseIs=0
GetColor="黑色"
CaseIs=13209
GetColor="褐色"
CaseIs=13107
GetColor="橄榄绿"
CaseIs=13056
GetColor="深绿"
CaseIs=6697728
GetColor="深灰蓝"
CaseIs=8388608
GetColor="深蓝"
CaseIs=10040115
GetColor="靛蓝"
CaseIs=3355443
GetColor="灰色-80%"
CaseIs=128
GetColor="深红"
CaseIs=26367
GetColor="桔黄"
CaseIs=32896
GetColor="深黄"
CaseIs=32768
GetColor="绿色"
CaseIs=8421376
GetColor="蓝绿色"
CaseIs=16711680
GetColor="蓝色"
CaseIs=10053222
GetColor="蓝-灰"
CaseIs=8421504
GetColor="灰色-50%"
CaseIs=255
GetColor="红色"
CaseIs=39423
GetColor="浅桔黄"
CaseIs=52377
GetColor="酸橙色"
CaseIs=6723891
GetColor="海绿"
CaseIs=13421619
GetColor="宝石蓝"
CaseIs=16737843
GetColor="浅蓝"
CaseIs=8388736
GetColor="紫色"
CaseIs=10066329
GetColor="灰色-40%"
CaseIs=16711935
GetColor="粉红"
CaseIs=52479
GetColor="金色"
CaseIs=65535
GetColor="黄色"
CaseIs=65280
GetColor="鲜绿"
CaseIs=16776960
GetColor="青绿"
CaseIs=16763904
GetColor="天蓝"
CaseIs=6697881
GetColor="梅红"
CaseIs=12632256
GetColor="灰色"
CaseIs=13408767
GetColor="玫瑰红"
CaseIs=10079487
GetColor="棕黄"
CaseIs=10092543
GetColor="浅黄"
CaseIs=13434828
GetColor="浅绿"
CaseIs=16777164
GetColor="浅青绿"
CaseIs=16764057
GetColor="淡蓝"
CaseIs=16751052
GetColor="淡紫"
CaseIs=16777215
GetColor="白色"
EndSelect
EndFunction
SubMacro2（）
'
'Macro2Macro
'宏在2013-4-19由许长安录制
'
'Windows（"党委工作报告（调试用）"）.Activate
ChangeFileOpenDirectory"C:
\DocumentsandSettings\Administrator\桌面\演示测试\"
Documents.OpenFileName:
="党委工作报告（调试用）.doc",ConfirmConversions:
=False,_
ReadOnly:
=False,AddToRecentFiles:
=False,PasswordDocument:
="",_
PasswordTemplate:
="",Revert:
=False,WritePasswordDocument:
="",_
WritePasswordTemplate:
="",Format:
=wdOpenFormatAuto,XMLTransform:
=""
ActiveWindow.View.Type=wdWebView
ActiveWindow.ActivePane.View.Zoom.Percentage=240
ActiveDocument.PrintPreview
IfActiveWindow.View.FullScreen=FalseThenActiveWindow.View.FullScreen=NotActiveWindow.View.FullScreen
IfActiveWindow.ActivePane.DisplayRulers=FalseThenActiveWindow.ActivePane.DisplayRulers=NotActiveWindow.ActivePane.DisplayRulers
ActiveDocument.ClosePrintPreview
CommandBars（"fullscreen"）.Visible=False
WithActiveWindow
.DisplayHorizontalScrollBar=False
EndWith
EndSub
Sub上下复制（）
'
'上下复制Macro
'宏由许长安录制，时间:
2016-1-5
'
'
'Range（"C131"）.Select
'Selection.Copy
'Range（"C132"）.Select
'ActiveSheet.Paste
'Range（"C133"）.Select
Row=0
Col=0
i=1
j=1
H=1
Row=ActiveCell.Row（）
Col=ActiveCell.Column（）
DoWhile（Worksheets（"Sheet1"）.Cells（Row,Col）<>""AndRow<1500）
DoWhile（Worksheets（"Sheet1"）.Cells（Row+i,Col）=""Andi<400）
Worksheets（"Sheet1"）.Cells（Row+i,Col）=Worksheets（"Sheet1"）.Cells（Row,Col）
i=i+1
Loop
Row=Row+i
i=1
Loop
H=MsgBox（"执行完毕!
"&Row&"|"&Col&Worksheets（"Sheet1"）.Cells（Row,Col）,1）
EndSub
FunctionOpenExcelFile（sPathAsString,ByValsFileNameAsString,bDisplayAsBoolean,sPwdAsString）AsInteger
'许长安录制，时间:
2016-2-4
'打开Excel文件
'参数说明：
'sPath:
文件绝对路径；sFileName:
Excel文件名；bDisplay:
True显示错误信息；sPwd:
文件打开密码
'返回值：
-1:
同名文件已经打开；-2:
文件不存在或密码错误；0:
成功打开；1:
文件已经被打开
DimbOpenAsBoolean
DimsFullNameAsString
OnErrorResumeNext
IfInStr（LCase（sFileName）,".xls"）=0ThensFileName=sFileName&".xls"
sFullName=Workbooks（sFileName）.FullName
'检查是否已经打开同名的Excel文件
'如果有sFullName不为空
OnErrorGoTo0
bOpen=False
IfsFullName<>""Then
IfLCase（sFullName）=LCase（sPath&"\"&sFileName）Then
bOpen=True
'判断已经打开的同名文件是否本次需要打开的文件
OpenExcelFile=1
'文件已经被打开
'MsgBox"请首先关闭“"&sFileName&"”文件！
"&Chr（13）&"不能同时打开同名文件，这是Excel的规定！
",vbOKOnly+vbExclamation,"文件的打开错误"
'Else
IfbDisplayThen
MsgBox"请首先关闭“"&sFileName&"”文件！
"&Chr（13）&"不能同时打开同名文件，这是Excel的规定！
",vbOKOnly+vbExclamation,"文件的打开错误"
EndIf
bOpen=True
OpenExcelFile=-1
'不能同时打开同名文件，这是Excel的规定
EndIf
EndIf
IfNotbOpenThen
OnErrorGoToerrOpen
Workbooks.OpenFileName:
=sPath&"\"&sFileName,Password:
=sPwd
OnErrorGoTo0
OpenExcelFile=0
'成功打开文件
EndIf
ExitFunction
errOpen:
IfbDisplayThenMsgBoxErr.Description,vbOKOnly+vbExclamation,"文件的打开错误"
OpenExcelFile=-2
'文件不存在或密码错误
OnErrorGoTo0
EndFunction
Subfileproce（）
'
'Macro5Macro
'宏由许长安录制，时间:
2016-2-28
'MergeArea.Rows.Count
'MergeArea.Columns.Count'
'Range（"B7:
B28"）.Select
'row=ActiveCell.row（）
'col=ActiveCell.Column（）
Dimi,hAsLong
Dimrow,col,rangrows,countrowsAsLong
i=0
'countrows=ActiveCell.row（）
'MsgBox"当前文件总并行数：
"&countrows&"！
"
'rangrows=Cells（row,col）.MergeArea.Rows.Count'从B列第7行开始
'Range（"B7:
B"&rangrows）.Select
'MsgBox"B7当前合并行数：
"&rangrows&"！
"
row=7'定义起始行数
col=2
DoWhilerowRange（"B"&row&":
B"&row）.Select
IfRange（"B"&row）.MergeCellsThen
WithSelection
.HorizontalAlignment=xlGeneral
.VerticalAlignment=xlCenter
.WrapText=True
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=True
EndWith
rangrows=Cells（row,col）.MergeArea.Rows.Count
Selection.UnMerge
DoWhileiRange（"B"&row+i）.Select
Selection.Copy
Range（"B"&row+i+1）.Select
ActiveSheet.Paste
i=i+1
Loop
row=row+i
EndIf
i=0
row=row+1
Loop
Range（"B7"）.Select
EndSub
Sub读取日成本异常数据（）
'
'读取日成本异常数据Macro
'宏由许长安录制，时间:
2016-2-25
'
'
'Range（"C7"）.Select
'Application.WindowState=xlMaximized
'Windows（"钢后实际价汇总_到钢种.xls"）.Activate
Dimi,h,m,n,jAsInteger
DimsFullPathAsString
DimsFileNameAsString
DimMyFileAsObject
col=17
row=2
SetMyFile=CreateObject（"Scripting.FileSystemObject"）
sFullPath=ThisWorkbook.Path'返回当前文件路径
'Format（Date,"yyyy年m月d日"）'当前年月日
'sFileName="钢后实际价汇总_到钢种20160224"'调试用
oFileName="钢后实际价汇总_到钢种"
sFileName="钢后实际价汇总_到钢种"&Format（Date-1,"yyyymmdd"）
MsgBoxsFullPath&sFileName&".xls"
IfMyFile.FileExists（sFullPath&"\"&sFileName&".xls"）=TrueThen
i=OpenExcelFile（sFullPath,sFileName,1,""）
Else
MsgBox"指定文件：
"&sFileName&"不存在！
"
ExitSub
'Application.Quit'退出当前应用程序
EndIf
Windows（sFileName）.Activate
fileproce'调用过程：
处理原始文件
'Windows（"钢后实际价汇总_到钢种.xls"）.Activate
'MsgBoxActiveSheet.UsedRange.Rows.Count（）'当前工作表总行数
'开始复制数据：
j=7'原始数据表第7行开始
Windows（sFileName&".xls"）.Activate
m=ActiveSheet.UsedRange.Rows.Count（）'原始数据表总行数
Windows（oFileName&".xls"）.Activate
n=ActiveSheet.UsedRange.Rows.Count（）'目标数据表总行数
DoWhilejWindows（sFileName&".xls"）.Activate
'MsgBoxCells（j,16）.Value
fff=Format（Cells（j,16）,"#,##0.000"）
If（fff>0.05Orfff<-0.05）AndCells（j,16）.Value<>""Then
Range（"B"&j&":
"&"I"&j）.Select
Selection.Copy
Windows（oFileName&".xls"）.Activate
Range（"B"&n+1）.Select
ActiveSheet.Paste
Windows（sFileName&".xls"）.Activate
Range（"P"&j&":
"&"Q"&j）.Select
Selection.Copy
Windows（oFileName&".xls"）.Activate
Range（"J"&n+1）.Select
ActiveSheet.Paste
Cells（n+1,1）.Value=Format（Date-1,"yyyymmdd"）'针对目标数据表第一列‘日期’格式设定
Range（"A"&n-1&":
"&"A"&n-1）.Select
Selection.Copy
Range（"A"&n+1）.Select
Selection.PasteSpecialPaste:
=xlPasteFormats,Operation:
=xlNone,_
SkipBlanks:
=False,Transpose:
=False
Application.CutCopyMode=False
n=n+1
EndIf
j=j+1
Windows（sFileName&".xls"）.Activate
Loop
Windows（oFileName&".xls"）.Activate
'h=MsgBox（"执行完毕!
"&row&"|"&col&Worksheets（"Sheet1"）.Cells（row,col）,1）
Workbooks（sFileName&".XLS"）.CloseSaveChanges:
=False
MsgBox"执行完毕!
"
EndSub
升级会员 