| 订阅 | 在线投稿
分享
 
 
 

各种Excel VBA的命令2

2008-09-02 06:53:54 编辑來源:互联网 国际版 评论
 
 
本文为【各种Excel VBA的命令2】的汉字拼音对照版显示拼音
  benshilichongfuzuijinyonghujiemianminglingbenshilibixufangzaihongdediyixing

  Application.Repeat

  xializhongbianliang counter daitilexinghaociguochengjiangzaidanyuangequyu C1:C20 zhongxunhuanjiangsuo

  youjueduizhixiaoyu 0.01 deshuzidoushezhiwei 0ling

  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

  zai Ne00:" 'zhidingdayinji

  ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,

  Collate:=True 'shezhidayinxinxi,qizhongCopies:=myPrintweidayinfenshu

  Else

  MsgBox "qingshuruyaodayindefenshu"

  End If

  ActiveSheet.ShowAllData 'quanbuxianshi

  ActiveSheet.Protect Password:=641112 ' baohugongzuobiaobingshezhimima

  Sheets("fengmian").Select

  Application.ScreenUpdating = True

  End Sub

  Sub dayinyue()

  Application.ScreenUpdating = False

  Sheets("yuebiao").Select

  Call chongsuansuoyoubiao

  ActiveSheet.Unprotect Password:=641112 'chexiaogongzuobiaobaohubingquxiaomima

  ActiveWindow.ScrollColumn = 10

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

  'yixia10xingtanchuchuangkoushurudayinxinxi

  Dim myPrintNum As Integer

  Dim myPrompt, myTitle As String

  myPrompt = "qingshuruyaodayindefenshu"

  myTitle = "dayinxuanqufanwei"

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

  If myPrintNum 0 Then

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

  Ne00:" ' 'zhidingdayinji

  ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,

  Collate:=True 'shezhidayinxinxi,qizhongCopies:=myPrintweidayinfenshu

  Else

  MsgBox "qingshuruyaodayindefenshu"

  End If

  ActiveSheet.ShowAllData 'quanbuxianshi

  ActiveSheet.Protect Password:=641112 ' baohugongzuobiaobingshezhimima

  Sheets("fengmian").Select

  Application.ScreenUpdating = True

  End Sub

  Sub beifen()

  Dim y 'bianliangshengming-xubaocungongzuobiaodelujinghemingcheng

  [M1] = ActiveWorkbook.FullName 'danyuangeM1=dangqiangongzuo簿baodelujinghemingcheng

  y = cells(1, 14) 'Y=danyuangeN1dezhi,jijisuanhoudexubaocungongzuo簿baode

  lujinghemingcheng

  Worksheets("fengmian").UsedRange.Columns("M:N").Calculate 'jisuanzhiding

  quyu

  ActiveWorkbook.SaveCopyAs y 'beifendaozhidinglumeY

  End Sub

  Sub chongsuanhuodongbiao()

  With Application

  .Calculation = xlManual

  .MaxChange = 0.001

  End With

  ActiveWorkbook.PrecisionAsDisplayed = True

  ActiveWindow.DisplayZeros = True

  ActiveSheet.Calculate

  End Sub

  Sub chongsuanzhidingbiao()

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

  Worksheets("yinxingzhang").Calculate

  Worksheets("ribaobiao").Calculate

  End Sub

  danyuangeshujugaibianyinqijisuanjihuoguocheng

  Private Sub Worksheet_Change(ByVal Target As Range)

  Dim irow, icol As Integer

  irow = Target.Row 'bianliangxingirow

  icol = Target.Column 'bianlianglieicol

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

  Then '>dayu6xing,bingqiedi3lie,dangbenxing 3lie>2xing3lie

  Application.EnableEvents = False

  cells(irow, 2) = cells(irow - 1, 2) 'benxing 2 lie=shangyixing2lie

  Application.EnableEvents = True

  ElseIf irow > 6 And icol = 3 And cells(irow, 3) dayu6xing,bingqiedi3lie,dangbenxing 3lie>2xing3lie

  Application.EnableEvents = False

  cells(irow, 2) = cells(irow - 1, 2) + 1 'benxing 2 lie=shangxing2lie+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) = "=danweimingcheng"

  cells(irow, 7) = "=zhaiyao"

  cells(irow, 11) = "=yue"

  Range(cells(irow, 14), cells(irow, 16)) = "=yuneiwaishouzhiNOP"

  cells(irow, 17) = "=shengaiQ"

  cells(irow, 18) = "=duizhangU"

  Range(cells(irow, 19), cells(irow, 20)) = "=neizhuanshouzhiXY"

  cells(irow, 21) = "=zhengcaiZ"

  Application.EnableEvents = True

  End If

  End Sub

  'jisuandangqiangongzuobiaolujingjimingchengdehanshu,kezuoweidanyuangegongshi,yekexieruhong

  =CELL("FILENAME")

  'gaibianExceljiemianbiaotidehong

  Private Sub Workbook_Open()

  Application.Caption = "chiguole"

  End Sub

  'zidongshuaxindanyuangeA1neixianshideriqi\shijiandehong

  Sub mytime()

  Range("a1") = Now()

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

  End Sub

  'yongdanyuangeA1deneirongzuoweiwenjianmingbaocundangqiangongzuo簿baodehong

  Sub b()

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

  End Sub

  'jihuochuangtidehong,cihongxieruyouchuangtidegongzuobiaonei

  Private Sub CommandButton1_Click() 'dianshujuluruanniukongjianjihuochuangti

  Load UserForm3 'jihuochuangti

  UserForm3.StartUpPosition = 3 'jihuochuangti

  UserForm3.Show 'jihuochuangti

  End Sub

  'yixiaweichuangtizhongdianjigeanniuyunxingdehong,xieruchuangtinei

  Public pos As Integer 'shengmingbianliangpos

  'zhanyouquedinganniuyuju

  Private Sub CommandButton1_Click()

  Application.ScreenUpdating = False 'cijuhezuihouyijuzhizaibuxian

  shihongdezhixingguocheng

  'On Error GoTo ErrorHandle 'keyibuyao

  'ErrorHandle: 'keyibuyao

  'If Err.Number = 13 Then 'keyibuyao

  'Exit Sub 'keyibuyao

  'End If 'keyibuyao

  Call writeToWorkSheet 'zhixinghongwritetoworksheet

  UserForm3.Hide '退tuichuchuangti,jixuanniushaociju,退tuichuanniuzhixingciju

  Unload UserForm3 '退tuichuchuangti,jixuanniushaociju,退tuichuanniuzhixingciju

  Call piliangdayin '[cichudaojieshunxu2]

  [L2] = "" '[daocichujieshu]

  Sheets("dayinxinxi").Select

  Application.ScreenUpdating = True

  End Sub

  '退tuichuanniuyuju

  Private Sub CommandButton2_Click()

  UserForm3.Hide

  Unload UserForm3

  End Sub

  'jiangchuangtineidewenbenkuangzhongdeshujuxiejingongzuobiaodedanyuange

  Private Sub writeToWorkSheet()

  ActiveSheet.Range("k2") = TextBox1.Value 'jiangwenzikuangneirongxiejinklie

  ActiveSheet.Range("l2") = TextBox2.Value 'jiangwenzikuangneirongxiejinllie

  TextBox1.Value = "" 'qingkongwenzikuangneirong

  TextBox2.Value = "" 'qingkongwenzikuangneirong

  Worksheets("dayinxinxi").Range("a2").Value = 1 'geizhidingbiaodedanyuangexieru

  shuju

  Worksheets("dayinxinxi").Range("B3:E113").Value = "" 'qingkongzhidingbiaodedanyuan

  geshuju

  End Sub

  'yixiaweigenjutiaojiandayindehong

  Sub dayin() 'bumenmingxichaxunjipixingdayin

  Application.ScreenUpdating = False 'guanbipingmugengxin

  If Cells(1, 4) = "" And Cells(1, 5) = "" Then 'dayintiaojianCells(3,

  13) = 1 And

  ' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL

  6 zai Ne00:" ' 'zhidingdayinji

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

  'shezhimorendayinjidedayinxinxi,qizhongCopies:=myPrintweidayinfenshu

  Else

  Call dayinxinxi 'dadaoweijiashizhixing

  End If

  Application.ScreenUpdating = True 'guanbipingmugengxin

  End Sub

  'yixiadexunhuanguocheng,yeyongyupiliangdayin,ZdezhikeyishiZ=1 TO 5(1dao5),yekeshidanyuangedenei

  rong

  Sub piliangdayin()

  For Z = Cells(1, 11) To Cells(1, 12) 'bianliangXdezhicongdayinqishihaoK1daojieshu

  haoL1zhijianzhujiandizeng

  Cells(1, 13) = Z 'M1dezhidengyubianliangX

  Next Z

  End Sub

  'yixiashijiangdayinqingkuangxierugongzuobiaodehong

  Sub dayinxinxi()

  Application.ScreenUpdating = False 'guanbipingmugengxin

  Dim Y 'shengmingbianliang

  Y = ActiveSheet.Name 'pandinghuodonggongzuobiaomingcheng

  Sheets("dayinxinxi").Select

  X = 3 'congdi3xingkaishi

  Do While Not (IsEmpty(Cells(X, 2).Value)) 'panduandi1liedezuihouyixing(

  jikongxingdeshangyixing)

  X = X + 1 'zaizuihouyixingjiayixingjiweikongxing

  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 'fanhuishangyicidakaidegongzuobiao

  Application.ScreenUpdating = True 'dakaipingmugengxin

  End Sub

  jiangwenjianbaocunweiyimouyidanyuangezhongdezhiweiwenjianmingdehongzenmexie

  jiasheniyaoyiSheet1deA1danyuangezhongdezhiweiwenjianmingbaocunzeyingyongmingling

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

  zaiExcelzhong,ruheyongchengshikongzhimouyidanyuangebukebianjixiugai?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:="quyu1", Range:=Range

  (RangeAddress) _

  , Password:="pass"

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

  End With

  End Sub

  duigongzuobiaobianchengyoushiyaopanduangongzuobiaodejiluzongshuVBAliruheshixian

  x=1

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

  x=x+1

  loop

  zaiVBAzhongdengtongyuEXCELEzhongdeqiuhehanshu-sum()-dehanshushishenme?

  Application.WorksheetFunction.Sum()

  zidingyicaidanyousangecaidanxiangyaoqiushougongshunxuzhixingweifangzhiwucaozuozhixingwandiyigecaidanxiang

  hou使shiqibianhuijinyongruhexie

  Rowen

  lingqi Enableshuxingtongbuyumougegongjuanniushijiaoweifang便biande

  ruhejinxingbiaogegengxin

  shizheyangdebiruwoyijingyouleyigeyuanshibiaogeAzheshiyourentongzhiwoAbiaoyoucuowuxujiayixiugai

  binggeiwoyigebiaoBbiaoBliechulexuxiugaideshenshuzhuyiBdelieshushaoyuAdelieshuyinAdeqita

  liewuxuxiugaixianzaiwentishiruhegenjubiaoBzhongdexinzhizaibiaoAzhongzhaodaoxiangyingweizhibingjiayixiu

  gaibirubiaoBzhongliechule10002deJOHNdeshengaohetichongdengzhixuyaoxiugairuhezaiAzhongzhaodao

  10002dexiangyingweizhishengaotichongbingjiayixiugai

  jianyijiangbiaobfuzhizhibiaoadesheet2ranhouzhixingxialiedehongjike

  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

  zidingyicaidan

  bajianliheshanchuzidingyicaidandedaimafenbiexiezaiWorkbook_openheWorkbook_beforeclosed

  deshijianzhong

  yinggaiyongVBAgongzuobodaimazhongyouworkbook-open()guochengzaigaiguochengzhongxieru

  with activeworkbook

  .sheets("biao2").active

  end with

  VBAshixianxiangsuodinggongzuobiaozhongcharuxing,bingzidongfuzhishangmianxingzhongzhidingliedehanshu

  Option Explicit

  Public Const strPass = "123" 123shikouling

  Sub xingshangzaicharuyixing()

  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

  ruhe使shibuchuxianmeiciguanbiXLSwenjianshichuxiande

  XXX.xlswenjianyibeixiugaishifoukezaiqixiugaihoudeneirongziyang

  keyizaigongzuobiaoguanbizhiqianjinxingshougongbaocungongzuo

  ThisWorkbook.save

  ruheshixiandongtaishijianxianshi?

  sub mytime

  range("a1")=now()

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

  end sub

  yong vba panduanzhiding excel wenjianshifoudakai

  For Each w In Workbooks

  If w.Name XXX Then

  

  End If

  Next w

  vbazenmetiaoyongexcelzidaidehanshu?biruvlookup?

  Application.WorksheetFunction.f(x)

  f(x)shinixiang使shiyongdegongzuobiaohanshu

  danshiyongneibuhanshushiyinyongdanyuangehuichucuozenmeban

  baniyaoyinyongdedanyuangegaichengVBArenkegeshileixingruzaiExcelzhongdeF7:F12yinggaiwei

  Range("F7:F12")deng

  VBAzhongruheguanbi,baocunhe退tuichuExcel?

  Workbooks("nidegongzuo簿bao").Save

  xiabiaojulishuomingle使shiyong Rows he Columns shuxingdeyixiexingheliedeyinyong

  yinyong hanyi

  Rows(1) diyixing

  Rows gongzuobiaoshangsuoyoudexing

  Columns(1) diyilie

  Columns("A") diyilie

  Columns gongzuobiaoshangsuoyoudelie

  ruoyaotongshichuliruoganxinghuolieqingchuangjianyigeduixiangbianliangbing使shiyong Union fangfajiangdui Rows shu

  xinghuo Columns shuxingdeduogetiaoyongzuheqilaixialijianghuodonggongzuo簿baozhongdiyizhanggongzuobiaoshangdedi

  yixingdisanxinghediwuxingdezitishezhiweijiacu

  Sub SeveralRows()

  Worksheets("Sheet1").Activate

  Dim myUnion As Range

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

  myUnion.Font.Bold = True

  End Sub

  ruguozhishinishuodezhilianjiejigechucungenayongjiandandefangfa

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

  huo

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

  qingwenzaivbaruhehujiaoyidingyidemingchengfanwei

  wozaia1:b100charumingchengmyrange

  qingwenworuheyongvbaxuanqucifanwei

  Range("myrange").Select

  ruhe访fangwenmeiyoudakaideEXCELwenjian

  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

  zenyang使shiVBAprjectgongchengbukechakanbuyongmima

  yongkebianjishiliujinzhiwenjianderuanjiangongjuruWinHexdengdakaiExcel.xls,zaiwenjiandeyibu,cha

  zhaoID="{00000000-0000-0000-0000-000000000000}"(yougongchengsuodingmimashi),huo

  ID="{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}"(meiyougongchengsuodingmimashi),xiugaiqizhong

  derenyi1weihou,baocun,jikedadaomude.dangchakangongchengshihuichuxiangongchengbukechakandetishi.

  zhuyi:xiugaiqian,yidingyaobeifenyuanwenjian,yifangbuce

  ruheyongVBAkongzhibaobiaodegeshizuobianjuzhizhangdaxiaodayindijiyedeng

  dayindijiyekongzhi:ActiveWindow.SelectedSheets.PrintOut From:=x, To:=y

  ActiveSheet.PageSetup.LeftMargin= zuobianju

  ActiveSheet.PageSetup..PaperSize = zhizhangdaxiao

  ruhe使shiVBAzidongxiaochu使shiyongCOPYfuzhihouchanshengdexu线xiankuang

  Application.CutCopyMode = False

  tihuanExcel 97decaidanlanshihenrongyidezhixuchuangjianyigexindecaidanlanjiuhuishanchuExcel 97de

  caidanlandangxuyaohuifuExcel 97decaidanlanshizhiyaoshanchuxinchuangjiandecaidanlanjiukeyilegai

  xitongdezidingyicaidanzhongzhixulianggeminglinganniuyigeyonglaifanhuidaoxitongdezhuhuamian

  ReturnMAINlingyigeyonglai退tuichuxitongExitSYSxiamianshimokuaiModulezhongyouguan

  dehonghuoshishijiankongzhichengxu

  Sub ZapMenu( )

  On Error Resume Next

  CommandBars(baoxianchaxunxitong).Delete

  End Sub

  zheshiyigeyonglaishanchuzidingyicaidanlandehongyujuOn Error Resume Nextbaozhengwulunzi

  dingyicaidanlanshifoucunzaidounengzhengqueshanchuta

  Sub ExitSYS( )

  ZapMenu

  ActiveWorkbook.Close SaveChanges := False

  End Sub

  zheshiyonglai退tuichuxitongdehongtashanchuzidingyicaidanbingguanbihuodongdegongzuo簿baobutishibaocun

  xiugai

  Sub ReturnMAIN( )

  Worksheets(baoxianchaxunxitong).Select

  End Sub

  gaihongyonglaifanhuizhuhuamiantajihuobaoxianchaxunxitonggongzuobiao

  Sub SetMenu( )

  Dim myBar As CommandBar

  Dim myButton As CommandBarButton

  ZapMenu

  Set myBar = CommandBars.Add(Name:=baoxianchaxunxitong, _

  Position :=msoBarTop, _

  MenuBar :=True)

  Set myButton = myBar.Controls.Add(msoControlButton)

  myButton. = msoButtonCaption

  myButton.Caption = 退tuichu[&E]

  myButton.OnAction = ExitSYS

  Set myButton = myBar.Controls.Add(msoControlButton)

  myButton. = msoButtonCaption

  myButton.Caption = fanhui[&R]

  myButton.OnAction = ReturnMAIN

  myButton.Visible = False

  myBar.Protection = msoBarNoMove + msoBarNoCustomize

  myBar.Visible = True

  End Sub

  zhegehongbaohanwubufendiyibufendingyileyiduibianliangdierbufenshouxianyunxingZapMenuhong

  baozhengbaoxianchaxunxitongcaidanlanshibucunzaideranhouchuangjiantashenshuMenuBardezhisheweiTrueque

  baozhegexinchuangjiandeminglinglanweiyicaidanlandisanbufenhedisibufenjianglianggeminglinganniujiarudaocaidan

  lanzhongbingshezhiReturnMAINminglinganniudechushizhuangtaiweibukejianzhuangtaizuihouyibufenbaohuzhege

  xinchuangjiandecaidanlan使shiyonghubunengyidongyebunengzidingyixincaidanlan

  gongzuobiaohuizong

  Sub sum() 'biaohuizong,di1zhangdea1:e20dengyusuoyoubiaodexiangtongdanyuangedehe

  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原文
 
 
本示例重复最近用户界面命令。本示例必须放在宏的第一行。 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 = "[url=file://\\zdserver2\HP]\\zdserver2\HP[/url] 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 = "[url=file://\\zdserver2\HP]\\zdserver2\HP[/url] 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 = "[url=file://\\zdserver2\HP]\\zdserver2\HP[/url] 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
󰈣󰈤
日版宠物情人插曲《Winding Road》歌词

日版宠物情人2017的插曲,很带节奏感,日语的,女生唱的。 最后听见是在第8集的时候女主手割伤了,然后男主用嘴帮她吸了一下,插曲就出来了。 歌手:Def...

兄弟共妻,我成了他们夜里的美食

老钟家的两个儿子很特别,就是跟其他的人不太一样,魔一般的执着。兄弟俩都到了要结婚的年龄了,不管自家老爹怎么磨破嘴皮子,兄弟俩说不娶就不娶,老父母为兄弟两操碎了心...

网络安全治理:国家安全保障的主要方向是打击犯罪,而不是处置和惩罚受害者

来源:中国青年报 新的攻击方法不断涌现,黑客几乎永远占据网络攻击的上风,我们不可能通过技术手段杜绝网络攻击。国家安全保障的主要方向是打击犯罪,而不是处置和惩罚...

 
 
 
>>返回首页<<
 为你推荐
 
 
 
 转载本文
 UBB代码 HTML代码
复制到剪贴板...
 
 
 热帖排行
 
黑色魅力_醉人的美
梦幻蒙眬_如痴如醉
北京的“尖叫”建筑
高天上流云
 
 
王朝网络微信公众号
微信扫码关注本站公众号wangchaonetcn
 
  免责声明:本文仅代表作者个人观点,与王朝网络无关。王朝网络登载此文出于传递更多信息之目的,并不意味着赞同其观点或证实其描述,其原创性以及文中陈述文字和内容未经本站证实,对本文以及其中全部或者部分内容、文字的真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
 
 
©2005- 王朝网络 版权所有