EXCEL中VBA基础应用2007-04-20 02:11:32| 分类： VBA学习 | 标签： |字号大中小 订阅 本示例为设置密码窗口 (1) If Application.InputBox("请输入密码：") = 1234 Then [A1] = 1 '密码正确时执行 Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码 End If
X = MsgBox("是否真的要结帐？", vbYesNo) If X = vbYes Then Close '以下是将打印情况写入工作表的宏 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"
Private Sub Workbook_Open() ProtectSpecialRange ("A1") End Sub
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
x=1 do while not (isempty(sheets("").cells(x,1).value) x=x+1 loop
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的事件中。
with activeworkbook .sheets("表2").active end with
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
“XXX.xls文件已被修改，是否可在其修改后的内容？”字样？？ 可以在工作表关闭之前进行手工保存工作 ThisWorkbook.save
sub mytime range("a1")=now() Application.OnTime Now + Timevalue("00:00:01"), "mytime" end sub
For Each w In Workbooks If w.Name <> XXX Then ………… End If Next w
Application.WorksheetFunction.f(x) f(x)是你想使用的工作表函数 但是用内部函数时引用单元格会出错，怎么办？ 把你要引用的单元格改成VBA认可格式（类型）。如在Excel中的“F7:F12”应改为“Range("F7:F12")”等。
Workbooks("你的工作簿").Save。
引用 含义 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选取此范围 Range("myrange").Select
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
用可编辑十六进制文件的软件工具（如WinHex等）打开Excel.xls,在文件的尾部,查找ID="{00000000-0000-0000-0000-000000000000}"(有工程锁定密码时),或ID="{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}"(没有工程锁定密码时),修改其中的任意1位后,保存,即可达到目的.当查看工程是会出现“工程不可查看”的提示. 注意:修改前,一定要备份原文件,以防不测
打印第几页控制:ActiveWindow.SelectedSheets.PrintOut From:=x, To:=y ActiveSheet.PageSetup.LeftMargin= 左边距 ActiveSheet.PageSetup..PaperSize = 纸张大小
Application.CutCopyMode = False
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:=“保险查询系统”, _ _ MenuBar :=True) Set myButton = myBar.Controls.Add(msoControlButton) myButton.Style = msoButtonCaption myButton.Caption = “退出[&E]” myButton.OnAction = “ExitSYS” Set myButton = myBar.Controls.Add(msoControlButton) myButton.Style = 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
ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码 ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码
For Each w In Workbooks If w.Name <> ThisWorkbook.Name Then w.Close SaveChanges:=True End If Next w
Application.WindowState = xlMaximized
MsgBox "The name of the active sheet is " & ActiveSheet.Name
ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"
Sheets(4).Activate '下述过程激活工作簿中的第1张工作表。 Worksheets(1).Activate
ThisWorkbook.Saved = True ThisWorkbook.Close
Worksheets(1).EnableCalculation = False
Workbooks.Open ("C:\MyFolder\MyBook.xls")
MsgBox Worksheets("Sheet1").Range("A1").Value
For Each ws In Worksheets MsgBox ws.Name Next ws
Set NewSheet = Worksheets.Add NewSheet.Name = "current Budget"
'Private Sub Workbook_NewSheet(ByVal Sh As Object) Sh.Move After:=Sheets(Sheets.Count) End Sub
'Private Sub App_WorkbookNewSheet(ByVal Wb As Workbook, _ ByVal Sh As Object) Sh.Move After:=Wb.Sheets(Wb.Sheets.Count) End Sub
Set NewSheet = Sheets.Add(Type:=xlWorksheet) For i = 1 To Sheets.Count NewSheet.Cells(i, 1).Value = Sheets(i).Name Next i
Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 10
'Private Sub Workbook_SheetCalculate(ByVal Sh As Object) With Worksheets(1) .Range("a1:a100").Sort Key1:=.Range("a1") End With End Sub 本示例显示工作表 Sheet1 的打印预览。 Worksheets("Sheet1").PrintPreview
ActiveWorkbook.Save
For Each w In Application.Workbooks w.Save Next w Application.Quit
Worksheets.Add Count:=2, Before:=Sheets(1) 本示例设置 15 秒后运行 my_Procedure 过程，从现在开始计时。 Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure"
Application.OnTime TimeValue("17:00:00"), "my_Procedure"
Application.OnTime EarliestTime:=TimeValue("17:00:00"), _ Procedure:="my_Procedure", Schedule:=False
'Private Sub Worksheet_Calculate() Columns("A:F").AutoFit End Sub
ActiveWorkbook.PrecisionAsDisplayed = True
Worksheets("Sheet1").Range("A1:G37").Cut
计算所有打开的工作簿、工作簿中的一张特定的工作表或者工作表中指定区域的单元格，如下表所示： '要计算 '依照本示例 所有打开的工作簿 ' Application.Calculate （或只是 Calculate） 指定工作表 '计算指定工作表Sheet1 Worksheets("Sheet1").Calculate 指定区域 'Worksheets(1).Rows(2).Calculate
Worksheets(1).EnableCalculation = False
Worksheets("Sheet1").UsedRange.Columns("A:C").Calculate
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
Worksheets(1).ScrollArea = "a1:f10"
Set NewBook = Workbooks.Add Do fName = Application.GetSaveAsFilename Loop Until fName <> False NewBook.SaveAs Filename:=fName
Workbooks.Open "ANALYSIS.XLS" ActiveWorkbook.RunAutoMacros xlAutoOpen
With ActiveWorkbook .RunAutoMacros xlAutoClose .Close End With
'Sub UseCanonical() Display the full path to user. MsgBox ActiveWorkbook.FullNameURLEncoded End Sub
MsgBox ActiveWorkbook.FullName
Workbooks("BOOK1.XLS").Close SaveChanges:=False
Workbooks.Close
'Private Sub Workbook_BeforePrint(Cancel As Boolean) For Each wk In Worksheets wk.Calculate Next End Sub
Set c1 = Sheets("sheet1").QueryTables(1).ResultRange.Columns(1) c1.Name = "Column1" c1.End(xlDown).Offset(2, 0).Formula = "=sum(Column1)"
ActiveWorkbook.RejectAllChanges
Worksheets("Sheet1").Activate SolverReset SolverOptions Precision:=0.001 SolverOK SetCell:=Range("TotalProfit"), _ MaxMinVal:=1, _ ByChange:=Range("C4:E6") SolverAdd CellRef:=Range("F4:F6"), _ Relation:=1, _ FormulaText:=100 SolverAdd CellRef:=Range("C4:E6"), _ Relation:=3, _ FormulaText:=0 SolverAdd CellRef:=Range("C4:E6"), _ Relation:=4 SolverSolve UserFinish:=False SolverSave SaveArea:=Range("A33")
Charts(Array("Chart1", "Chart3", "Chart5")).Visible = False
'Private Sub Worksheet_Activate() Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscending End Sub
ActiveWorkbook.ChangeLink "c:\excel\book1.xls", _ "c:\excel\book2.xls", xlExcelLinks
ActiveSheet.EnableAutoFilter = True ActiveSheet.Protect contents:=True, userInterfaceOnly:=True
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
ActiveWorkbook.AutoUpdateFrequency = 3
'Sub ClearSheet() Worksheets("Sheet1").Cells.ClearContents End Sub
Application.DisplayScrollBars = False
'Sub SetPasswordOptions() With ActiveWorkbook If .PasswordEncryptionProvider <> "Microsoft RSA SChannel Cryptographic Provider" Then .SetPasswordEncryptionOptions _ PasswordEncryptionProvider:="Microsoft RSA SChannel Cryptographic Provider", _ PasswordEncryptionAlgorithm:="RC4", _ PasswordEncryptionKeyLength:=56, _ PasswordEncryptionFileProperties:=True End If End With End Sub
'Sub UseWritePassword() Dim strPassword As String strPassword = "secret" ' Set password to a string if allowed. If ActiveWorkbook.WriteReserved = False Then ActiveWorkbook.WritePassword = strPassword End If End Sub
'Sub UsePassword()
wkbOne.Close '注意 Password 属性可读并返回 “********”。 End Sub
Workbooks("BOOK1.XLS").Worksheets("Sheet1").Activate ActiveWindow.DisplayFormulas = True
ActiveWorkbook.AcceptAllChanges
Sub UseCanonical() MsgBox '消息框 [b7] = ActiveWorkbook.FullName '当前工作簿 [b8] = ActiveWorkbook.FullNameURLEncoded '活动工作簿 End Sub
MsgBox Application.StartupPath
For Each ws In Worksheets MsgBox ws.Name Next ws
For Each w In Workbooks If w.Name <> ThisWorkbook.Name Then w.Close savechanges:=True End If Next w
激活一个工作簿、工作表、图表或嵌入图表时产生此事件。 当激活工作表时，本示例对 A1:A10 区域进行排序。 Private Sub Worksheet_Activate() Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscending End Sub
对于 Worksheet 对象，在对工作表进行重新计算之后产生此事件 每当工作表重新计算时，本示例就调整 A 列到 F 列的宽度。 Private Sub Worksheet_Calculate() Columns("A:F").AutoFit End Sub
应用于 Worksheet 对象的 Activate 方法。 当双击某工作表时产生此事件，此事件先于默认的双击操作。 Private Sub expression_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) expression 引用在类模块中带有事件声明的 Worksheet 类型对象的变量。 Target 必需。双击发生时最靠近鼠标指针的单元格。 Cancel 可选。当事件发生时为 False。如果事件过程将该参数设为 True，则该过程执行完之后将不进行默认的双击操作。
应用于 Worksheet 对象的 Activate 方法。 当用鼠标右键单击某工作表时产生此事件，此事件先于默认的右键单击操作。 Private Sub expression_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) expression 引用在类模块中带有事件声明的 Worksheet 类型对象的变量。 Target 必需。右键单击发生时最靠近鼠标指针的单元格。 Cancel 可选。当事件发生时为 False。如果该事件过程将本参数设为 True，则该过程执行结束之后不进行默认的右键单击操作。
当用户更改工作表中的单元格，或外部链接引起单元格的更改时产生此事件。 Private Sub Worksheet_Change(ByVal Target As Range) Target 更改的区域。可以是多个单元格。 说明 重新计算引起的单元格更改不触发本事件。可使用 Calculate 事件俘获工作表重新计算操作。 本示例将更改的单元格的颜色设为蓝色。 Private Sub Worksheet_Change(ByVal Target as Range) Target.Font.ColorIndex = 5 End Sub
图表、工作表或工作簿从活动状态转为非活动状态时产生此事件。 Private Sub object_Deactivate() object Chart、Workbook 或者 Worksheet。有关对 Chart 对象使用事件的详细信息，请参阅 Chart 对象事件的用法。 本示例当工作簿转为非活动状态时，对所有打开的窗口进行排列。 Private Sub Workbook_Deactivate() Application.Windows.Arrange xlArrangeStyleTiled End Sub
当单击工作表上的任意超链接时，发生此事件。对于应用程序级或工作簿级的事件，请参阅 SheetFollowHyperlink 事件。 Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) Target Hyperlink 类型，必需。一个代表超链接目标位置的 Hyperlink 对象。 本示例对在当前活动工作簿中访问过的所有链接保留一个列表或历史记录。 Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) With UserForm1 .ListBox1.AddItem Target.Address .Show End With End Sub
发生在工作簿中的数据透视表更新之后。 Private Sub expression_PivotTableUpdate(ByVal Target As PivotTable) expression 引用在类模块中带有事件声明的 Worksheet 类型对象的变量。 Target 必需。选定的数据透视表。 本示例显示一则消息，说明数据透视表已经更新。本示例假定您已在类模块中声明了带有事件的 Worksheet 类型的对象。 Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable) MsgBox "The PivotTable connection has been updated." End Sub
当工作表上的选定区域发生改变时，将产生本事件。 Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Target 新选定的区域。 本示例滚动工作簿窗口，直至选定区域位于窗口的左上角。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) With ActiveWindow .ScrollRow = Target.Row .ScrollColumn = Target.Column End With End Sub
MsgBox Worksheets("Sheet1").Range("A1").Value
For Each ws In Worksheets MsgBox ws.Name Next ws
Set newSheet = Worksheets.Add newSheet.Name = "current Budget"
Application.DisplayAlerts = False Workbooks("BOOK1.XLS").Close Application.DisplayAlerts = True
Application.PromptForSummaryInfo = True
Private Sub aa() MsgBox "The path is " & Application.Path End Sub
For Each a In AddIns MsgBox a.FullName Next a
改变当前的目录或文件夹。 ChDir path 在 Power Macintosh 中，默认驱动器总是改为在 path 语句中指定的驱动器。完整路径指定由卷标名开始，相对路径由冒号 (:) 开始. ChDir 可以辨认路径中指定的别名: ChDir "MacDrive:Tmp" ' 在 Macintosh 中
MsgBox "The path separator character is " & _ Application.PathSeparator
将一个指定的文件或文件夹从一个地方移动到另一个地方。 语法 object.Move destination Move 方法语法有如下几部分： 部分 描述 object 必需的。始终是一个 File 或 Folder 对象的名字。 destination 必需的。文件或文件夹要移动到的目标。不允许有通配符。
创建一个文件夹。 语法 object.CreateFolder(foldername) reateFolder 方法有如下几部分： 部分 描述 object 必需的。始终是一个 FileSystemObject 的名字。 foldername 必需的。字符串表达式，它标识创建的文件夹。
MkDir "MYDIR" ' 建立新的目录或文件夹。 Name 语句示例 本示例使用 Name 语句来更改文件的名称。示例中假设所有使用到的目录或文件夹都已存在。 在 Macintosh 中，默认驱动器名称是 “HD” 并且路径部分由冒号取代反斜线隔开。 Dim OldName, NewName OldName = "OLDFILE": NewName = "NEWFILE" ' 定义文件名。 Name OldName As NewName ' 更改文件名。 OldName = "C:\MYDIR\OLDFILE": NewName = "C:\YOURDIR\NEWFILE" Name OldName As NewName ' 更改文件名，并移动文件。
MsgBox "The current default file path is " & _ Application.DefaultFilePath
Application.AltStartupPath = "C:\EXCEL\MACROS"
如果指定的文件夹存在返回 True，不存在返回 False。 语法 object.FolderExists(folderspec)
Application.EditDirectlyInCell = True
Advanced Office 2000 Password Recovery 破解VBA的程序 我学VBA时的两本书！《excle2000vba开发实例指南》晶辰工作室 《excle2002函数应用秘笈》中国铁路出版社
几种用VBA在单元格输入数据的方法： Public Sub Writes() 1-- 2 方法，最简单在 "[ ]" 中输入单元格名称。 1 [A1] = 100 '在 A1 单元格输入100。 2 [A2:A4] = 10 '在 A2:A4 单元格输入10。 3-- 4 方法，采用 Range(" ")， " " 中输入单元格名称。 3 Range("B1") = 200 '在 B1 单元格输入200。 4 Range("C1:C3") = 300 '在 C1:C3 单元格输入300。 5-- 6 方法，采用 Cells(Row,Column)，Row是单元格行数，Column是单元格栏数。 5 Cells(1, 4) = 400 '在 D1 单元格输入400。 6 Range(Cells(1, 5), Cells(5, 5)) = 50 '在 E1:E 5单元格输入50。 End Sub
Public Sub Selection1() Selection.Value = "Test" '在任何你点选的单元格输入文字 "Test"。 End Sub
几种如何把别的工作表 Sheet4 数据，读到这个工作表的方法：在被读取的单元格前加上工作表名称 Sheet4。 Public Sub Writes() 1-- 2 方法，最简单在被读取的 "[ ]" 前加上被读取的工作表名称 Sheet4。 1 [A1] = Sheet4.[A1] '把Sheet4 A1 单元格的数据，读到 A1单元格。 2 [A2:A4] = Sheet4.[B1] ''把 Shee4 工作表单元格 B1 数据，读到 A2:A4 单元格。 3-- 4 方法，在被读取的工作表 Range(" ")的 Range 前加上被读取的工作表名称Sheet4。 3 Range("B1") = Sheet4.Range("B1") ''把 Shee4工作表单元格 B1 数据，读到 B1 单元格。 4 Range("C1:C3") = Sheet4.Range("C1") '把 Shee4 工作表单元格 C1 数据，读到 C1:C3 单元格。 5-- 6 方法，在被读取的工作表 Cells(Row,Column)，Cells 前加上被读取工作表名称 Sheet4。 5 Cells(1, 4) = Sheet4.Cells(1, 4) '把 Shee4 工作表单元格 D1 数据，读到 D1 单元格。 6 Range(Cells(1, 5), Cells(5, 5)) = Sheet4.Cells(1, 5) '把 Shee4 工作表单元格 E1 数据，读到 E1:E 5单元格。 End Sub
Public Sub Selection1() Selection.Value = Sheet4.[F1] '把 Shee4 工作表单元格 F1 数据，读到任何你点选的单元格。 End Sub
如何利用 Worksheet_SelectionChange 输入数据的方法。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Target = 100 End Sub
可以是一个也可以是好几个单元格。 Range 是 Excel 特有的变量形态，叫范围。 Target As Rang 是把 Target 这个参数设定为 Range 变量形态。 Target = 100 是把你点选的单元格输入数字100。
如何利用 Worksheet_SelectionChange 在限定的单元格输入数据的方法。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 2 And Target.Column = 2 Then Target = 100 End If End Sub
Target.Row >= 2，指的是鼠标选定的单元格的行大于或等于 2。 Target.Column = 2 ，指的是鼠标选定的单元格的栏等于 2。 If Target.Row >= 2 And Target.Column = 2 Then 指的是只有在Target.Row >= 2及Target.Column = 2二个条件成立时。 就是 (Target.Row >= 2) 为True及(Target.Column = 2)为True时，才执行下面的程序 Target=100， 也就是 B 栏第二行及以下行用鼠标被点选时，才会被输入100，其它单元格则不被输入数据。
比较 Worksheet_SelectionChange() 与用按钮 CommandButton1_Click() 来执行程序二者的方法与写法有何不同。 Worksheet_SelectionChange()事件 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 2 And Target.Column = 2 Then Target = 100 End If End Sub
Private Sub CommandButton1_Click() If ActiveCell.Row >= 2 And ActiveCell.Column >= 3 Then ActiveCell = 100 End If End Sub
按钮 CommandButton1_Click() 是人工的，比 SelectionChange()多一道手续，就是要去按那接钮，程序才会执行。 SelectionChange() 有一个参数 Target 可用；CommandButton1_Click ()没有。 所以我们要用 ActiveCell 内定函数来取代Target，ActiveCell 与 Target最大的不同点他只能指定一个单元格。 就是你选取多个单元格也只有最上面的单元格会加上数据；用 Selection 取代 ActiveCell， 用法就跟 Target 一样了。
完整的 If...Then ┅ End 逻辑判断式。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 2 And Target.Column = 2 Then Target = 200 ElseIf Target.Row >= 2 And Target.Column = 3 Then Target = 300 ElseIf Target.Row >= 2 And Target.Column = 2 Then Target = 400 Else Target = 500 End If End Sub
Else 的意思是说，假如以上条件都不成立的话，就执行第八条程序。 他的执行方式是假如 IF 的条件成立的话，就不执行其它ElseIf 及Else 的逻辑判断式，假如 If 後的条件不成立的话才会执行 ElseIf 或 Else 逻辑判断式。第二个 ElseIf後的条件因为与 IF 後的条件一样，所以这个判断式後面的 Target=400 将是永远无法执行到的程序。
Dim i , j As Integer Dim k As Range i = Target.Row j = Target.Column Set k = Target If i >= 2 And j = 2 Then k = 200 ElseIf i >= 2 And j = 3 Then k = 300 ElseIf i >= 2 And j = 4 Then k = 400 Else k = 500 End If End Sub
使用变量前，你得先宣告变量。宣告变量的方法是在 "Dim " 后面写上变量 " i " As 后面接上变量的形态 "Integer"。 Dim i , j As Integer 就是宣告 i 与 j 为整数变量，这是同时宣告二个变量 i 与 j 所以要在二个变量间加个 " , "号。 Dim k As Range 是宣告 k 为范围资料形态，Range这是 Excel 特有的资料形态。 i = Target.Row是把当前单元格的行数，指定给变量 i。 j = Target.Column 是把当前单元格的栏数，指定给变量 j。 Set k = Target 是把当前的单元格，指定给变量 k。 用像 i 与 j 这样简单的变量，在程序的前面你可能还记得 i 或 j 代表着什厶。程序写长了，你可能忘记 i 或 j 代表着什厶。所以最好的方法是用比较有意义的代号，来为变量命名如 iRow 或 iCol 来取代 i 及 j 。
Dim iRow, iCol As Integer iRow = Target.Row iCol = Target.Column If iRow >= 2 And iCol = 2 And Target <> "" Then Application.EnableEvents = False Cells(iRow, iCol + 1) = Cells(iRow, iCol) * 2 Application.EnableEvents = True ElseIf iRow >= 2 And iCol = 2 And Target = "" Then Cells(iRow, iCol + 1) = "" Else Cells(iRow, iCol + 1) = "" End If End Sub
这个教程就是要让你来体会什厶是Worksheet_Chang()事件。因为这二个事件在VBA都是非常有用的，所以一定要了解。 简单的说，前者是你鼠标移动到那个单元格，就触发那个事件的执行。後者是要等到你点选的单元格，数 有了改变才会触发事件的执行。二者执行的时机一前一後。 Target <> "" 是代表限定当前的单元格要是有数 的，才会执行以下三行的程序。 Cells(iRow, iCol + 1) = Cells(iRow, iCol) * 2，是你在 B 栏输入数 时，C 栏将可得到 B 栏二倍的数 。 Target = "" 是限定当前的单元格要是没有数 的，才会执行以下一行的程序。 Cells(iRow, iCol + 1) = ""，是把 C 栏的数 清成空格。 Application.EnableEvents = False与Application.EnableEvents = True，这是个成双的程序，当你用了前者记得在执行其他程序後要写上後面的程序。它的目的在抑制事件连锁执行。简单的说就是，在 B 字段所触发的事件，不愿在其它单元格再触发另一个Worksheet_Change()事件。
Dim iRow As Integer iRow = Target.Row Application.EnableEvents = False Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2) Application.EnableEvents = True End Sub
Dim iRow As Integer iRow = Target.Row 'Application.EnableEvents = False Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2) 'Application.EnableEvents = True End Sub
照上面有加上 Application.EnableEvents = False 程序执行当然没问题。 现在你在 Application.EnableEvents = False 与 Application.EnableEvents = True 前加上「 '」看看。 程序前加上「 '」的目的是要使「 '」之后的文字变成说明文字，程序执行时是会跳过说明文字，不执行说明文字的内容。 程序前加上「 '」符号后，文字会变成绿色。 执行第二个程序时，你将发现 C2 不会按你所要求的，呈现结果。 这就是所谓的事件连锁反应。
我想运行一个宏,就能在当前工作表B3上填上一条公式;这条公式的结果是所有工作 表上的B4单元格的和.请问这个宏该如何写.谢谢! Sub gg() Dim sh As Worksheet, shname$ For Each sh In Worksheets shname = sh.Name ActiveSheet.Range("b3").value = ActiveSheet.Range("b3").value + Worksheets(shname).Range("b4") Next End Sub
通过VBA编程，很容易添加新的工作表，但是新表的名字不知怎样控制，对于新创建的工作表，由于其名字并非特定，所以就不好使用所创建的新表了。不知各位有何高见。。。。 Sheets.Add ActiveSheet.Name = "table"
To yxptwq∶用这程序试看看。 Sub Copy1() Dim Row_dn1, Row_dnN, i, j, n As Integer Row_dn1 = Sheet1.Range("A65536").End(xlUp).Row k = 1: n = 1 For Each wSheet In ActiveWorkbook.Worksheets With wSheet If .Name <> "Sheet1" Then Row_dnN = .Range("A65536").End(xlUp).Row For i = 2 To Row_dn1 For j = 2 To Row_dnN If .Cells(j, 1) = Sheet1.Cells(i, 1) Then .Rows(j & ":" & j).Copy Destination:=Sheet1.Rows(Row_dn1 + n & ":" & Row_dn1 + n) n = n + 1 End If Next j Next i End If End With Next wSheet End Sub
'程式说明:利用SendKey输入VBAProject密码 '注意事项:执行本程式需要在Excel视窗,不能在VBE视窗 Application.SendKeys "%{F11}", True 'Alt + F11 切换到VBA视窗 Application.SendKeys "%T", True 'ALT + T 工具(繁体中文是(T)) Application.SendKeys "e", True '工具(T)-VBproject属性(E) Application.SendKeys "^{TAB}", True 'TAB 键(切换到PAge2 保护页面) Application.SendKeys "{+}", True '选取Checkbox方块(锁定专案以供检视) '({+} 选取, {-} 取消选取) Application.SendKeys "{TAB}", True 'TAB 键(跳到第一次输入密码 Textbox myPW = "chijanzen" '假设密码 chijanzen Application.SendKeys myPW, True '输入密码 Application.SendKeys "{TAB}", True 'TAB 键(跳到第二次输入密码 Textbox Application.SendKeys myPW, True '输入密码 Application.SendKeys "{ENTER}", True '按确定钮(预设值) Application.SendKeys "%{F11}", True '返回Excel视窗 End Sub
冒泡排序法之所以成为“冒泡排序”是因为值较小的或是较轻的元素浮到作为继续排序的一组数的顶部。 Sub Macro1() Dim i As Integer Dim j As Integer Dim t as integer Static number(1 To 10) As Integer For i = 1 To 10 number(i) = inputbox“输入要排序的数：” Next i
For j = 1 To i – 1 ‘下面进行位置交换 If number(j) > number(j + 1) Then t = number(j + 1) number(j + 1) = number(j) number(j) = t End If
Next i
Print number(i) Next i End sub
——“快速排序”，具体算法可参考数据结构等有关书籍。对所有数据排序后再合 并相同数据，合并程序较为简便，我开始时采用了这种方法，但后来发现对于这些 的数据，先合并后排序速度更快，因为有大量相同的数据。合并是采用“标记”算 法，具体如下：（设数据已存放在sData()数组中 ，结果存到Queryp()数组， Amount是数据个数） '把相同元素置 0 For i = 1 To Amount If sData(i) <> 0 Then For j = i ＋ 1 To Amount
Next j End If Next i '删除相同元素 Queryp(1) = sData(1) k = 1 For i = 2 To Amount If Not (sData(i) = 0) Then k = k ＋ 1 Queryp(k) = sData(i) End If Next i kMax = k ReDim Preserve Queryp(kMax) 虽然这样使得运算速度有所高，但是仍然要进行大量的循环运算，占据了程序大部 分的运算时间。于是我一直在寻觅一种更为高效的算法。 功夫不负有心人，在仔细分析数据的特征，比较了多种方案之后，我终于找到了一 种相当成功的算法，原来要3到4秒的运算缩短到仅需0.1到0.2秒。 我遇到的数据具有以下特征：①相同数据很多，②最大、最小数之间相差不到3， ③都是带两位小数的正数。 针对数据的特征，我采用了以下算法： 针对数据的特征，我采用了以下算法： 步骤： 1． 用一个循环找出整数和小数部分的最大、最小值。小数部分的最大、最小值乘 以100转为整数。 2． 定义一个二维数组，下标范围分别是整数和小数部分的最小值到最大值。 3． 再用一个循环把所有源数据填入刚才定义的二维数组，填写规则是，源数据的 整数和小数部分分别对应二维数组的两个下标。例如，“13.51"填到“A(13,51)" 中。 4． 最后顺向或逆向读取二维数组中的非零数据即可得到从小到大或从大到小排列 的数据，而且不会含有重复数据。 用VB 编写的程序如下： '＊＊＊＊密集型数据处理＊＊＊＊ Dim i As Long, j As Long, k As Long, kMax As Long Dim Queryp() As Single ReDim Queryp(Amount) Dim IntegerPart As Integer, DecimalPart As Integer Dim IPmax As Integer, IPmin As Integer Dim DPmax As Integer, DPmin As Integer Dim DiffDataArray() '读取数据 ReadData IPmax = 0: IPmin = 1000 DPmax = 0: DPmin = 99
' 找整数和小数部分的最大、最小值 IntegerPart = Int(sData(i)) DecimalPart = (sData(i) － IntegerPart) ＊ 100 If IntegerPart > IPmax Then IPmax = IntegerPart ElseIf IntegerPart < IPmin Then IPmin = IntegerPart End If If DecimalPart > DPmax Then DPmax = DecimalPart ElseIf DecimalPart < DPmin Then DPmin = DecimalPart End If Next i ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax) '填入数据 For i = 1 To Amount IntegerPart = Int(sData(i)) DecimalPart = (sData(i) － IntegerPart) ＊ 100 DiffDataArray(IntegerPart, DecimalPart) = sData(i) Next i Next i '提取数据 k = 0 For i = IPmax To IPmin Step －1 For j = DPmax To DPmin Step －1 If DiffDataArray(i, j) <> 0 Then k = k ＋ 1 Queryp(k) = DiffDataArray(i, j) End If Next j Next i kMax = k ReDim Preserve Queryp(kMax) 该方法对于本人遇到的这种“密集型”数据最为有效，但是如果遇上“稀疏型”数 据，例如最大、最小值相差几千，甚至上万的数据，就没什么优势了，而且会占用 较大的内存。 经过改进，我得到了处理稀疏型数据的高效算法。高效的前提条件同样是源数据具 有大量相同数据。思路是在前一种方法的基础上增加一个单维数组，用来保存整数 部分数据，保存过程中用插入法对其进行排序。因为有大量重复数据，要排序的数 据量相对较少。当从二维数组中读取数据时，用单维数组代入二维数组的第一个下 标，具体代码下： '＊＊＊＊稀疏型数据处理＊＊＊＊ Dim i As Long, j As Long, k As Long, kMax As Long
ReDim Queryp(Amount) Dim IntegerPart As Integer, DecimalPart As Integer Dim IPmax As Integer, IPmin As Integer Dim DPmax As Integer, DPmin As Integer Dim IPArray() As Integer, IPAamount As Integer ReDim IPArray(Amount) Dim DiffDataArray() '读取数据
IPmax = 0: IPmin = 1000 DPmax = 0: DPmin = 99 IPAamount = 0 For i = 1 To Amount '获取整数和小数部分的最大最小值 IntegerPart = Int(sData(i)) DecimalPart = (sData(i) － IntegerPart) ＊ 100 If IntegerPart > IPmax Then IPmax = IntegerPart ElseIf IntegerPart < IPmin Then IPmin = IntegerPart IPmin = IntegerPart End If If DecimalPart > DPmax Then DPmax = DecimalPart ElseIf DecimalPart < DPmin Then DPmin = DecimalPart End If '对整数部分"IPArray()"进行插入法排序 (从大到小） For j = 1 To IPAamount If IntegerPart > IPArray(j) Then IPAamount = IPAamount ＋ 1 For k = IPAamount To j ＋ 1 Step －1 IPArray(k) = IPArray(k － 1) Next k IPArray(j) = IntegerPart Exit For ElseIf IntegerPart = IPArray(j) Then Exit For End If Next j If j > IPAamount Then IPAamount = IPAamount ＋ 1 IPArray(IPAamount) = IntegerPart
Next i ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax) '填入数据 For i = 1 To Amount IntegerPart = Int(sData(i)) DecimalPart = (sData(i) － IntegerPart) ＊ 100 DiffDataArray(IntegerPart, DecimalPart) = sData(i) Next i '提取数据 k = 0 For i = 1 To IPAamount For j = DPmax To DPmin Step －1 If DiffDataArray(IPArray(i), j) <> 0 Then k = k ＋ 1 Queryp(k) = DiffDataArray(IPArray （i), j) End If Next j Next i kMax = k ReDim Preserve Queryp(kMax) k ReDim Preserve Queryp(kMax) 具体采用哪种算法，要看数据的性质而定，以下是本人的一些实测数据，仅供参考 。如果你有更好的方法，可不要忘记和朋友们分享哦。 |
|
|
