VBA代码与疑难问题备忘录.docx

VBA代码与疑难问题备忘录.docx

《VBA代码与疑难问题备忘录.docx》由会员分享，可在线阅读，更多相关《VBA代码与疑难问题备忘录.docx（30页珍藏版）》请在冰豆网上搜索。

VBA代码与疑难问题备忘录

VBA语句备忘2

1.excel插入多行2

2.VB文字框怎样用键盘控制数字加减？

2

3.vba中用框架实现控件数组2

4.word和Excel文档关闭前添加打开权限密码2

5.vb计算两个日期之间天数3

6.字符串倒置（包括excel自定义函数）3

7.用word表格内单元格文字命名文件3

8.vb代码实现在word菜单中的"文件另存为"3

9.WORD表格每行的各列合并为一列3

10.计算空格数可以用以下公式：

4

11.替换6位数的末尾一位为A4

12.word编辑标记显示与否的设置4

13.通配符与正则表达式4

14.光标运动5

15.建立新word文档，写入，保存，关闭5

16.工作簿属性控制次数5

17.判断字符串是否为数字5

18.打印文档5

19.字母在字母表中位置6

20.工作表中数据区域判断6

21.返回字段中某个字符的个数6

22.A11输入一个数值Q,且Q不能大于表格B116

23.If公式6

代码备忘6

1.Subexcel列数字排序并插入行（）6

2.excel中插入图片并设置图片大小7

3.word表格中成绩小于60的红色7

4.vb输入文字到文本框并保存文本框内容到文本文件8

5.遍历文件夹内文本文件（气象文件），重新排版，重命名并另存为文本文件9

6.Sub遍历文件夹内文件用属性更名（）11

7.如何取得文本文件的行数?

12

8.第2，3，4列中成这样的形式：

12

9.A1为3，则B1为123；A2为5，则B2为1234513

10.不定长度的A列求和13

11.用excel访问网页并自动提交数据14

12.本示例将MyDoc.doc中的每张图片转换为嵌入式图形。

14

13.[分享]VBA提取网页数据（4种方法）14

14.如何用VBA提交网页表单啊？

15

15.Sub表格1单元格1行3列命名文件并保存（）15

16.替换字符串中的数字或者非数字为空格，以空格为split，输出到数组16

17.word连续替换，有时候需要先清除格式16

18.打印编号递增word17

19.急,在线等VBA关于网页表单问题17

20.请输入正整数17

21.插入目录18

22.VBA转换EXCEL列到另一个表中相对应的行，Transpose18

23.删除空行（使用过的表）18

24.连云港天气预报查询并保存18

心得备忘19

1.word不连续页码19

2.用自动更正的方法可以套用样式20

3.word多级标题做成20

4.word通配符使用20

5.word或者excel界面上宏控件21

VBA语句备忘

11.excel插入多行

Fori=1To3

Rows（3）.Insert

Next

Rows

（2）.Resize（3）.Insert

21.VB文字框怎样用键盘控制数字加减？

PrivateSubText1_KeyDown（KeyCodeAsInteger,ShiftAsInteger）

IfKeyCode=38ThenText1=Val（Text1）+1

IfKeyCode=40ThenText1=Val（Text1）-1

EndSub

31.vba中用框架实现控件数组

Frame1.Controls（i）

41.word和Excel文档关闭前添加打开权限密码

PrivateSubDocument_Close（）

ActiveDocument.Password="12345"

EndSub

PrivateSubWorkbook_BeforeClose（CancelAsBoolean）

ActiveWorkbook.Password="12345"

EndSub

51.vb计算两个日期之间天数

text3.text=DateDiff（"d",text1.text,text2.text）

61.字符串倒置（包括excel自定义函数）

=RETEXT（A1）

按下ALT+F11,菜单:

插入-模块,复制下面代码至代码框.退出

FunctionReText（text）AsString

ReText=StrReverse（text）

EndFunction

71.用word表格内单元格文字命名文件

ActiveDocument.Tables

（1）.Cell（2,3）.Select

Selection.MoveLeftunit:

=wdCharacter,Extend:

=wdExtend

ActiveDocument.SaveAsFileName:

=ThisDocument.Path&"\"&Selection.Text&".doc"

81.vb代码实现在word菜单中的"文件另存为"

dimwdappAsWord.Application

wdapp.ActiveWindow.Application.CommandBars（"file"）.Controls.Item（5）.Executewdapp.ActiveWindow.Application.CommandBars（"file"）.Controls.Item（"另存为（&A）..."）.Execute

91.WORD表格每行的各列合并为一列

用vba可实现.

在word文档按"alt键+F11"切换到"vb编辑器"界面

点击工具栏中的"插入>模块"

在随后弹出的窗体中将下面的代码拷贝过去,再按"F5"键运行即可

（注:

代码中"tables

（1）"中的1为表格的引用号,如要操作第二个表格则将1改为2即可）

SubMacro1（）

DimnRowAsRow

ForEachnRowInActiveDocument.Tables

（1）.Rows

nRow.Cells.Merge

Next

101.计算空格数可以用以下公式：

=len（A1）-len（istext（a1））

111.替换6位数的末尾一位为A

=LEFT（A1,5）&"A"

公式为:

=REPLACEB（A1,6,1,"A"）

说明:

A1为原文本,如200818所在的位置，6表示从第6位开始，1表示替换1位，"A"表示替换为A

121.word编辑标记显示与否的设置

ActiveWindow.View.ShowHiddenText=True

隐藏文字不显示

ActiveWindow.ActivePane.View.ShowAll=False

不显示所有编辑标记，就是双刀

131.通配符与正则表达式

（[[]*[]]）（*）（^13）替换为\1^p或者\1^p均可，就是不能替换为\1^13，否则会变成软回车

Excel中欲查找~号，必须使用~~，因为~是脱字符。

空格软回车制表符加段落标记任意两个以上组合，删除（两个空格也会被替换成段落标记）

Selection.Find.Executefindtext:

="[^i^13^32^t]{2,}",replacewith:

="^p",MatchWildcards:

=True,Replace:

=wdReplaceAll,Wrap:

=wdFindContinue

提取字符串中的数字

DimmyReg

stringt="12erer34er56er"

SetmyReg=CreateObject（"vbscript.Regexp"）

myReg.Global=True

myReg.Pattern="[^\d/+]"

Numbert=myReg.Replace（stringt,""）

MsgBoxNumbert

SetmyReg=Nothing

屏蔽所有文本

FunctionGetNum$（testAsString）

DimmyReg

SetmyReg=CreateObject（"vbscript.Regexp"）

myReg.Global=True

myReg.Pattern="[^\d]"

GetNum=myReg.Replace（test,""）

SetmyReg=Nothing

EndFunction

141.光标运动

Application.ScreenUpdating=False'关闭屏幕刷新

Selection.HomeKeyUnit:

=wdStory

.CollapseDirection:

=wdCollapseEnd'折叠区域到区域的末尾

.MoveStartUntilCset:

="]",Count:

=wdBackward

'区域的开始位置扩展到到字符的后面，wdBackward是倒着移动（从后向前）

.MoveEndUnit:

=wdCharacter,Count:

=-1'区域末尾减少一个字符

151.建立新word文档，写入，保存，关闭

ForDocName=InputBox（"请输入起卦事由做文件名的前半部分"）

SetNewDoc=Documents.add

NewDoc.Content.InsertAfterResult

NewDoc.SaveAsFileName:

=ForDocName&BenGuahao&"变"&BianGuaHao&".doc"

NewDoc.Close

161.工作簿属性控制次数

时间型：

ThisWorkbook.CustomDocumentProperties.AddName:

="Opentime",_

LinkToContent:

=False,_

Type:

=msoPropertyTypeDate,_

Value:

=Date

数值型：

PrintTimes=ThisWorkbook.CustomDocumentProperties（"PrintTimes"）.Value+1

171.判断字符串是否为数字

IfIsNumeric（Pnt）Then

181.打印文档

ThisDocument.PrintOut

ThisWorkbook.PrintOut

191.字母在字母表中位置

FunctionC2N（Col）

ColStr="ABCDEFGHIJKLMNOPQRSTUVWXYZ"

C2N=InStr（1,ColStr,Col,1）

EndFunction

201.工作表中数据区域判断

LastRow=Sheet1.Range（"a65536"）.End（xlUp）.Row

Cn=Sheet1.Range（"Z1"）.End（xlToLeft）.Column

Rn=Sheet1.UsedRange.Rows.Count

Cn=Sheet1.UsedRange.Columns.Count

firstRow=Sheet2.UsedRange.Row

LastRow=firstRow+Sheet2.UsedRange.Rows.Count-1

211.返回字段中某个字符的个数

假如数据在A1

=LEN（A1）-LEN（SUBSTITUTE（A1,"A",""））

221.A11输入一个数值Q,且Q不能大于表格B11

在A11设置数据有效性。

选中A11，数据－有效性，“允许”选“自定义”，“公式”输入=A11<=B11。

需要的话设置一下“出错警告”。

231.If公式

b1=IF（ISERROR（SEARCH（"砂岩",A1））=FALSE,1,IF（ISERROR（SEARCH（"页岩",A1））=FALSE,2,""））

代码备忘

11.Subexcel列数字排序并插入行（）

DimRn,i,j,k,AllNo,YourColumnAsInteger

YourColumn=InputBox（"请输入需要排序的列号（数字），默认为A列","排序程序","1"）

Columns（YourColumn）.SortKey1:

=Cells（1,1）,Order1:

=xlAscending,Header:

=xlGuess,_

OrderCustom:

=1,MatchCase:

=False,Orientation:

=xlTopToBottom,SortMethod_

:

=xlPinYin,DataOption1:

=xlSortNormal

Rn=Sheet1.Range（"a65536"）.End（xlUp）.Row

AllNo=Sheet1.Range（"a65536"）.End（xlUp）.Value

Fori=1ToAllNo

j=Cells（i,YourColumn）.Value-i

Ifj>0Then

Rows（i）.Resize（j）.Insert

EndIf

Nexti

EndSub

21.excel中插入图片并设置图片大小

DimFirstRow,LastRowAsInteger,FileType,PicDirAsString

FirstRow=Sheet1.UsedRange.Row

LastRow=FirstRow+Sheet1.UsedRange.Rows.Count–1

'.Cells（65536,1）.End（xlUp）.Row

FileType=InputBox（"输入你的图片的后缀名","输入图片格式","jpg"）

PicDir=InputBox（"请输入图片所在目录","这里是本对话框的标题","E:

\PIC"）

Fori=FirstRowToLastRow

Numb=Cells（i,2）.Value

WithActiveSheet

.Pictures.Insert（PicDir&"\"&Numb&"."&FileType）.Select

SetTarget=.Cells（i,1）

EndWith

WithSelection

.Top=Target.Top+1

.Left=Target.Left+1

.Width=Target.Width-1

.Height=Target.Height-1

EndWith

Nexti

EndSub

ActiveSheet.Shapes（"Picture4"）.Select

WithSelection

.ShapeRange.LockAspectRatio=msoTrue

.ShapeRange.Height=150

EndWith

31.word表格中成绩小于60的红色

Subcolor（）

DimTotalRowsAsInteger,TotalColumnsAsInteger,TNAsInteger

TotalRows=ActiveDocument.Tables

（1）.Rows.Count

TotalColumns=ActiveDocument.Tables

（1）.Columns.Count

TN=InputBox（"要变色的表格是文档中的第几个？

请输入序号","输入表格序号",1）

Fori=1ToTotalRows

Forj=1ToTotalColumns

ActiveDocument.Tables（TN）.Cell（i,j）.Select

Selection.MoveLeftunit:

=wdCharacter,Count:

=1,Extend:

=wdExtend

a=Selection.Text

IfIsNumeric（a）=TrueAnda>60ThenSelection.Font.color=wdColorRed

Nextj

Nexti

EndSub

41.vb输入文字到文本框并保存文本框内容到文本文件

代码修改如下：

SubForm_Load（）

DimTextLine1

DimTextLine2

DimTextLine3

OpenApp.Path&"\text.ini"ForInputAs#1'打开文件。

Input#1,TextLine1

Input#1,TextLine2

Input#1,TextLine3'读入数据并将其赋予某变量。

Close#1

Text1.Text=TextLine1'第一次需保存一个示例格式到ini文件

Text2.Text=TextLine2

Text3.Text=TextLine3

EndSub

PrivateSubForm_Unload（CancelAsInteger）

OpenApp.Path&"\text.ini"ForOutputAs#1

Print#1,Text1.Text

Print#1,Text2.Text

Print#1,Text3.Text

Close#1

EndSub

51.遍历文件夹内文本文件（气象文件），重新排版，重命名并另存为文本文件

DimxAsString,MyNameAsString,NewTitleAsString

DimkAsInteger,iAsInteger

DimTotalFilesAsInteger

OnErrorResumeNext

Folder:

'提示输入目录

x=InputBox（Prompt:

="请添加要改名文件所在目录"&vbCr&vbCr_

&"例如:

C:

\MyDocuments",_

Default:

=Options.DefaultFilePath（wdDocumentsPath））

Ifx=""Orx=""Then

IfMsgBox（"输入目录有错误"_

&vbCr&"或者点击了取消，确定要退出吗?

"_

&vbCr&vbCr&_

"如果你想输入目录名，点击No."&vbCr&_

"如果想退出程序，点击Yes.",vbYesNo）=vbYesThen

ExitSub

Else

GoToFolder

EndIf

EndIf

'检查目录是否存在

IfDir（x,vbDirectory）=""Then

MsgBox"目录不存在，请重试."

GoToFolder

EndIf

'在目录中查找文件

WithApplication.FileSearch

.NewSearch

.FileType=msoFileTypeAllFiles

.LookIn=x

.Execute

TotalFiles=.FoundFiles.Count

IfTotalFiles=0Then

MsgBox（"该目录中没有文件!

"&_

"请输入其他目录。

"）

GoToFolder

EndIf

EndWith

Fork=1ToTotalFiles

j=Application.FileSearch.FoundFiles（k）

Documents.Openj

j.Active

WithSelection

.HomeKeyunit:

=wdStory

With.Find

.Executefindtext:

="",Wrap:

=wdFindContinue,MatchWildcards:

=False,Replace:

=wdReplaceAll,replacewith:

=""

.Executefindtext:

="150"

Selection.EndKeyunit:

=wdStory,Extend:

=wdExtend

Selection.Delete

.Executefindtext:

="h=",Wrap:

=wdFindContinue,MatchWildcards:

=False,Replace:

=wdReplaceAll,replacewith:

="^p"

.Executefindtext:

="

?

?

[tdf]{1,2}=",Wrap:

=wdFindContinue,MatchWildcards:

=True,Replace:

=wdReplaceAll,replacewith:

=""

EndWith

paracount=ActiveDocument.Paragraphs.Count

Fori=1Toparacount

SelectCaseiMod6

Case1

ActiveDocument.Paragraphs（i）.Range.Select

.HomeKeyunit:

=wdLine

.InsertBefore"start"

Case0,2To5

ActiveDocument.Paragraphs（i）.Range.Select

a=.Characters.Count

SelectCasea

Case6

.InsertBefore""

Case5

.InsertBefore""

Case4

.InsertBefore""

Case3

.InsertBefore""

Case2

.InsertBefore""

EndSelect

EndSelect

Nexti

With.Find

.ClearFormatting

.Replacement.ClearFormatting

.Executefindtext:

="^p",Wrap:

=wdFindContinue,MatchWildcards:

=False,Replace:

=wdReplaceAll,replacewith:

=""

.Executefindtext:

="start",Wrap:

=wdFindContinue,replacewith:

="^p",Replace:

=wdReplaceAll

EndWith

.HomeKeyunit:

=wdStory

.InsertBefore"层高度温度露点风向风速"

EndWith

WithActiveDocument

NewTitle=x&"\"&"重排版"&.Name

.SaveAsNewTitle

.Close

EndWith

Nextk