分享
 
 
 

各种Excel VBA的命令2

王朝vb·作者佚名  2008-09-02
窄屏简体版  字體: |||超大  

本示例重复最近用户界面命令。本示例必须放在宏的第一行。

Application.Repeat

下例中,变量 counter 代替了行号。此过程将在单元格区域 C1:C20 中循环,将所

有绝对值小于 0.01 的数字都设置为 0(零)。

Sub RoundToZero1()

For Counter = 1 To 20

Set curCell = Worksheets("Sheet1").Cells(Counter, 3)

If Abs(curCell.Value) 0 Then

' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL 6

在 Ne00:" '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,

Collate:=True '设置打印信息,其中Copies:=myPrint为打印份数

Else

MsgBox "请输入要打印的份数"

End If

ActiveSheet.ShowAllData '全部显示

ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码

Sheets("封面").Select

Application.ScreenUpdating = True

End Sub

Sub 打印余额()

Application.ScreenUpdating = False

Sheets("余额表").Select

Call 重算所有表

ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码

ActiveWindow.ScrollColumn = 10

Selection.AutoFilter Field:=1, Criteria1:=""

'以下10行弹出窗口输入打印信息

Dim myPrintNum As Integer

Dim myPrompt, myTitle As String

myPrompt = "请输入要打印的份数"

myTitle = "打印选取范围"

myPrintNum = Application.InputBox(myPrompt, myTitle, 4, , , , , 1)

If myPrintNum 0 Then

' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL 6 在

Ne00:" ' '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,

Collate:=True '设置打印信息,其中Copies:=myPrint为打印份数

Else

MsgBox "请输入要打印的份数"

End If

ActiveSheet.ShowAllData '全部显示

ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码

Sheets("封面").Select

Application.ScreenUpdating = True

End Sub

Sub 备份()

Dim y '变量声明-需保存工作表的路径和名称

[M1] = ActiveWorkbook.FullName '单元格M1=当前工作簿的路径和名称

y = cells(1, 14) 'Y=单元格N1的值,即计算后的需保存工作簿的

路径和名称

Worksheets("封面").UsedRange.Columns("M:N").Calculate '计算指定

区域

ActiveWorkbook.SaveCopyAs y '备份到指定路么Y

End Sub

Sub 重算活动表()

With Application

.Calculation = xlManual

.MaxChange = 0.001

End With

ActiveWorkbook.PrecisionAsDisplayed = True

ActiveWindow.DisplayZeros = True

ActiveSheet.Calculate

End Sub

Sub 重算指定表()

Attribute 重算指定表.VB_ProcData.VB_Invoke_Func = "z\n14"

Worksheets("银行帐").Calculate

Worksheets("日报表").Calculate

End Sub

单元格数据改变引起计算激活过程

Private Sub Worksheet_Change(ByVal Target As Range)

Dim irow, icol As Integer

irow = Target.Row '变量行irow

icol = Target.Column '变量列icol

If irow > 6 And icol = 3 And cells(irow, 3) >= cells(irow - 1, 3)

Then '>大于6行,并且第3列,当本行 3列>2行3列

Application.EnableEvents = False

cells(irow, 2) = cells(irow - 1, 2) '本行 2 列=上一行2列

Application.EnableEvents = True

ElseIf irow > 6 And icol = 3 And cells(irow, 3) 大于6行,并且第3列,当本行 3列>2行3列

Application.EnableEvents = False

cells(irow, 2) = cells(irow - 1, 2) + 1 '本行 2 列=上行2列+1

Application.EnableEvents = True

ElseIf (icol = 3 Or icol = 4 Or icol = 6 Or icol = 8 Or icol = 9 Or

icol = 10 Or icol = 12 Or icol = 13) And irow > 6 Then 'And Target

""

Application.EnableEvents = False

cells(irow, 5) = "=单位名称"

cells(irow, 7) = "=摘要"

cells(irow, 11) = "=余额"

Range(cells(irow, 14), cells(irow, 16)) = "=预内外收支NOP"

cells(irow, 17) = "=审核Q"

cells(irow, 18) = "=对帐U"

Range(cells(irow, 19), cells(irow, 20)) = "=内转收支XY"

cells(irow, 21) = "=政采Z"

Application.EnableEvents = True

End If

End Sub

'计算当前工作表路径及名称的函数,可作为单元格公式,也可写入宏

=CELL("FILENAME")

'改变Excel界面标题的宏

Private Sub Workbook_Open()

Application.Caption = "吃过了"

End Sub

'自动刷新单元格A1内显示的日期\时间的宏

Sub mytime()

Range("a1") = Now()

Application.OnTime Now + TimeValue("00:00:01"), "mytime"

End Sub

'用单元格A1的内容作为文件名保存当前工作簿的宏

Sub b()

ActiveWorkbook.SaveCopyAs Range("A1") + ".xls"

End Sub

'激活窗体的宏,此宏写入有窗体的工作表内

Private Sub CommandButton1_Click() '点数据录入按钮控件激活窗体

Load UserForm3 '激活窗体

UserForm3.StartUpPosition = 3 '激活窗体

UserForm3.Show '激活窗体

End Sub

'以下为窗体中点击各按钮运行的宏,写入窗体内

Public pos As Integer '声明变量pos

'战友确定按钮语句

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False '此句和最后一句旨在不显

示宏的执行过程

'On Error GoTo ErrorHandle '可以不要

'ErrorHandle: '可以不要

'If Err.Number = 13 Then '可以不要

'Exit Sub '可以不要

'End If '可以不要

Call writeToWorkSheet '执行宏writetoworksheet

UserForm3.Hide '退出窗体,继续按钮少此句,退出按钮执行此句

Unload UserForm3 '退出窗体,继续按钮少此句,退出按钮执行此句

Call 批量打印 '[此处到接顺序2]

[L2] = "" '[到此处结束]

Sheets("打印信息").Select

Application.ScreenUpdating = True

End Sub

'退出按钮语句

Private Sub CommandButton2_Click()

UserForm3.Hide

Unload UserForm3

End Sub

'将窗体内的文本框中的数据写进工作表的单元格

Private Sub writeToWorkSheet()

ActiveSheet.Range("k2") = TextBox1.Value '将文字框内容写进k列

ActiveSheet.Range("l2") = TextBox2.Value '将文字框内容写进l列

TextBox1.Value = "" '清空文字框内容

TextBox2.Value = "" '清空文字框内容

Worksheets("打印信息").Range("a2").Value = 1 '给指定表的单元格写入

数据

Worksheets("打印信息").Range("B3:E113").Value = "" '清空指定表的单元

格数据

End Sub

'以下为根据条件打印的宏

Sub 打印() '部门明细查询及批星打印

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

If Cells(1, 4) = "" And Cells(1, 5) = "" Then '打印条件Cells(3,

13) = 1 And

' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL

6 在 Ne00:" ' '指定打印机

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

'设置默认打印机的打印信息,其中Copies:=myPrint为打印份数

Else

Call 打印信息 '打倒为假时执行

End If

Application.ScreenUpdating = True '关闭屏幕更新

End Sub

'以下的循环过程,也用于批量打印,Z的值可以是Z=1 TO 5(1到5),也可是单元格的内

Sub 批量打印()

For Z = Cells(1, 11) To Cells(1, 12) '变量X的值从打印起始号K1到结束

号L1之间逐渐递增

Cells(1, 13) = Z 'M1的值等于变量X

Next Z

End Sub

'以下是将打印情况写入工作表的宏

Sub 打印信息()

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

Dim Y '声明变量

Y = ActiveSheet.Name '判定活动工作表名称

Sheets("打印信息").Select

X = 3 '从第3行开始

Do While Not (IsEmpty(Cells(X, 2).Value)) '判断第1列的最后一行(

即空行的上一行)

X = X + 1 '在最后一行加一行即为空行

Loop

Cells(X, 2) = Cells(2, 1)

Cells(X, 3) = Sheets(Y).Cells(4, 3)

Cells(2, 1) = Cells(2, 1) + 1

Cells(X, 4) = Sheets(Y).Cells(1, 4)

Cells(X, 5) = Sheets(Y).Cells(1, 5)

[c1] = Y

Sheets(Y).Select '返回上一次打开的工作表

Application.ScreenUpdating = True '打开屏幕更新

End Sub

将文件保存为以某一单元格中的值为文件名的宏怎么写

假设你要以Sheet1的A1单元格中的值为文件名保存,则应用命令:

ActiveWorkbook.SaveCopyAs Str(Range("Sheet1!A1")) + ".xls"

在Excel中,如何用程式控制某一单元格不可编辑修改?thanks!!!

Private Sub Workbook_Open()

ProtectSpecialRange ("A1")

End Sub

Sub ProtectSpecialRange(RangeAddress As String)

On Error Resume Next

With Sheet1

.Cells.Locked = False

.Range(RangeAddress).Locked = True

.Protection.AllowEditRanges.Add Title:="区域1", Range:=Range

(RangeAddress) _

, Password:="pass"

.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End With

End Sub

对工作表编程,有时要判断工作表的记录总数,VBA里如何实现?

x=1

do while not (isempty(sheets("").cells(x,1).value)

x=x+1

loop

在VBA中等同于EXCELE中的求和函数-sum()-的函数是什么?

Application.WorksheetFunction.Sum()

自定义菜单有三个菜单项,要求手工顺序执行。为防止误操作,执行完第一个菜单项

后使其变灰(禁用),如何写?

Rowen

令其 Enable属性同步与某个工具按钮是较为方便的。

如何进行表格更新?

是这样的,比如我已经有了一个原始表格A,这时有人通知我A表有错误,须加以修改

,并给我一个表B,表B列出了须修改的参数(注意B的列数少于A的列数,因A的其他

列无需修改)。现在问题是如何根据表B中的新值,在表A中找到相应位置,并加以修

改。比如表B中列出了10002的JOHN的身高和体重等值需要修改,如何在A中找到

10002的相应位置(身高体重),并加以修改。

建議將表b複製至表a的sheet2,然後執行下列的宏即可

sub change()

dim dd as range

sheets(2).select

lastcell = range("a65536").end(xlup).row

for each dd in range(cells(2, 1), cells(lastcell, 1))

if dd = "" then exit sub

ff = dd.value

set c = sheets(1).columns(1).find(ff, lookat:=xlwhole)

if not c is nothing then

c.offset(0, 2) = dd.offset(0, 2)

c.offset(0, 3) = dd.offset(0, 3)

c.offset(0, 5) = dd.offset(0, 4)

end if

next

end sub

自定义菜单

把建立和删除自定义菜单的代码分别写在Workbook_open和Workbook_beforeclosed

的事件中。

应该用VBA,工作薄代码中有workbook-open()过程,在该过程中写入

with activeworkbook

.sheets("表2").active

end with

VBA实现向锁定工作表中插入行,并自动复制上面行中指定列的函数

Option Explicit

Public Const strPass = "123" 123是口令

Sub 行上再插入一行()

ActiveSheet.Unprotect password:=strPass

Selection.Copy

Selection.Insert Shift:=xlDown

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,

SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

ActiveSheet.Protect password:=strPass

End Sub

如何使不出现每次关闭XLS文件时出现的:

“XXX.xls文件已被修改,是否可在其修改后的内容?”字样??

可以在工作表关闭之前进行手工保存工作

ThisWorkbook.save

如何实现动态时间显示?

sub mytime

range("a1")=now()

Application.OnTime Now + Timevalue("00:00:01"), "mytime"

end sub

用 vba 判断指定 excel 文件是否打开?

For Each w In Workbooks

If w.Name XXX Then

…………

End If

Next w

vba怎么调用excel自带的函数?比如vlookup?

Application.WorksheetFunction.f(x)

f(x)是你想使用的工作表函数

但是用内部函数时引用单元格会出错,怎么办?

把你要引用的单元格改成VBA认可格式(类型)。如在Excel中的“F7:F12”应改为

“Range("F7:F12")”等。

VBA中如何关闭,保存和退出Excel?

Workbooks("你的工作簿").Save。

下表举例说明了使用 Rows 和 Columns 属性的一些行和列的引用。

引用 含义

Rows(1) 第一行

Rows 工作表上所有的行

Columns(1) 第一列

Columns("A") 第一列

Columns 工作表上所有的列

若要同时处理若干行或列,请创建一个对象变量并使用 Union 方法,将对 Rows 属

性或 Columns 属性的多个调用组合起来。下例将活动工作簿中第一张工作表上的第

一行、第三行和第五行的字体设置为加粗。

Sub SeveralRows()

Worksheets("Sheet1").Activate

Dim myUnion As Range

Set myUnion = Union(Rows(1), Rows(3), Rows(5))

myUnion.Font.Bold = True

End Sub

如果只是你说的只连接几个储存格那用简单的方法

Range("A1").Formula = Application.Evaluate("=[Book2.xls]Sheet1!A1")

Range("A1").Formula = "=[Book2.xls]Sheet1!A1"

请问在vba如何呼叫已定义的名称范围

我在a1:b100插入名称∶myrange

请问我如何用vba选取此范围

Range("myrange").Select

如何访问没有打开的EXCEL文件?

Sub AlternativeImport()

Dim xlapp As Excel.Application

Dim wbSource As Excel.Workbook

Set xlapp = New Excel.Application

xlapp.EnableEvents = False

Set wbSource = xlapp.Workbooks.Open("C:\test\Book2.xls")

Range("A1:A10").Value = wbSource.Sheets("Sheet1").Range

("A1:A10").Value

wbSource.Close False

xlapp.Quit

End Sub

怎样使VBAprject工程不可查看?(不用密码)

用可编辑十六进制文件的软件工具(如WinHex等)打开Excel.xls,在文件的尾部,查

找ID="{00000000-0000-0000-0000-000000000000}"(有工程锁定密码时),或

ID="{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}"(没有工程锁定密码时),修改其中

的任意1位后,保存,即可达到目的.当查看工程是会出现“工程不可查看”的提示.

注意:修改前,一定要备份原文件,以防不测

如何用VBA控制报表的格式(左边距,纸张大小,打印第几页等)

打印第几页控制:ActiveWindow.SelectedSheets.PrintOut From:=x, To:=y

ActiveSheet.PageSetup.LeftMargin= 左边距

ActiveSheet.PageSetup..PaperSize = 纸张大小

如何使VBA自动消除使用COPY复制后产生的虚线框?

Application.CutCopyMode = False

替换Excel 97的菜单栏是很容易的,只需创建一个新的菜单栏就会删除Excel 97的

菜单栏。当需要恢复Excel 97的菜单栏时,只要删除新创建的菜单栏就可以了。该

系统的自定义菜单中只需两个命令按钮,一个用来返回到系统的主画面

(ReturnMAIN),另一个用来退出系统(ExitSYS)。下面是模块(Module)中有关

的宏或是事件控制程序。

Sub ZapMenu( )

On Error Resume Next

CommandBars(“保险查询系统”).Delete

End Sub

这是一个用来删除自定义菜单栏的宏。语句On Error Resume Next保证无论自

定义菜单栏是否存在都能正确删除它。

Sub ExitSYS( )

ZapMenu

ActiveWorkbook.Close SaveChanges := False

End Sub

这是用来退出系统的宏。它删除自定义菜单,并关闭活动的工作簿(不提示保存

修改)。

Sub ReturnMAIN( )

Worksheets(“保险查询系统”).Select

End Sub

该宏用来返回主画面。它激活“保险查询系统”工作表。

Sub SetMenu( )

Dim myBar As CommandBar

Dim myButton As CommandBarButton

ZapMenu

Set myBar = CommandBars.Add(Name:=“保险查询系统”, _

Position :=msoBarTop, _

MenuBar :=True)

Set myButton = myBar.Controls.Add(msoControlButton)

myButton. = msoButtonCaption

myButton.Caption = “退出[&E]”

myButton.OnAction = “ExitSYS”

Set myButton = myBar.Controls.Add(msoControlButton)

myButton. = msoButtonCaption

myButton.Caption = “返回[&R]”

myButton.OnAction = “ReturnMAIN”

myButton.Visible = False

myBar.Protection = msoBarNoMove + msoBarNoCustomize

myBar.Visible = True

End Sub

这个宏包含五部分。第一部分定义了一对变量。第二部分首先运行ZapMenu宏,

保证保险查询系统菜单栏是不存在的,然后创建它。参数MenuBar的值设为True,确

保这个新创建的命令栏为一菜单栏。第三部分和第四部分将两个命令按钮加入到菜单

栏中。并设置ReturnMAIN命令按钮的初始状态为不可见状态。最后一部分保护这个

新创建的菜单栏,使用户不能移动也不能自定义新菜单栏。

工作表汇总

Sub sum() '表汇总,第1张的a1:e20等于所有表的相同单元格的和

Attribute sum.VB_ProcData.VB_Invoke_Func = "z\n14"

Dim X As Worksheet

For y = 1 To 20

For z = 1 To 5

For Each X In Worksheets

shname = X.Name

ActiveSheet.Cells(y, z).Value = ActiveSheet.Cells(y, z).Value +

Worksheets(shname).Cells(y, z)

Next

Next z

Next y

End Sub

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有