各种Excel VBA的命令2

  本示例重复最近用户界面命令。本示例必须放在宏的第一行。
  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