宏命令语句.docx
- 文档编号:9837043
- 上传时间:2023-02-06
- 格式:DOCX
- 页数:16
- 大小:18.19KB
宏命令语句.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
DoWhilerow Range("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 DoWhilei Range("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()'目标数据表总行数 DoWhilej Windows(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
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- 命令 语句
![提示](https://static.bdocx.com/images/bang_tan.gif)