程序错误继续执行
On Error Resume Next
屏幕不更新
Application.ScreenUpdating = False
Application.ScreenUpdating = True
警示为假
Application.DisplayAlerts = False
关掉文件不保存
Windows(o).Activate
ActiveWorkbook.Close savechanges:=False
定义选中区域的坐标
dim x,y
x = Selection.Row() '行数
y = Selection.Column() '列数
单元格所在的行数
ActiveCell.Row ‘活动单元格所在的行数
ActiveCell.Column ‘活动单元格所在的列数
通过使用行列编号，可用Cells 属性来引用单个单元格。该属性返回代表单个单元格的Range 对象。下例中，Cells(6,1) 返回Sheet1 上的单元格A6，然后将Value 属性设置为10。
Sub EnterValue()
Worksheets("Sheet1").Cells(6, 1).Value = 10
End Sub
因为可用变量替代编号，所以Cells 属性非常适合于在单元格区域中循环，如下例所示。
Sub CycleThrough()
Dim Counter As Integer
For Counter = 1 To 20
Worksheets("Sheet1").Cells(Counter, 3).Value = Counter
Next Counter
End Sub
在命名区域中的单元格上循环
下例用For Each...Next 循环语句在命名区域中的每一个单元格上循环。如果该区域中的任一单元格的值超过limit 的值，就将该单元格的颜色更改为黄色。
Sub ApplyColor()
Const Limit As Integer = 25
For Each c In Range("MyRange")
If c.Value > Limit Then
c.Interior.ColorIndex = 27
End If
Next c
End Sub
增加一个workbooks, name Carrier
Workbooks.Add
ActiveWorkbook.SaveAs "D:\BOM Produce\carrier.xls", _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
增加一个表单，获取name
Sheets.Add
x = https://www.doczj.com/doc/f24976243.html,
Sheets(x).Select
插入一列
Range("E5").Select
Selection.EntireRow.Insert
插入一栏
Range("F6").Select
Selection.EntireColumn.Insert
向右移动一格
ActiveCell.Offset(0, -1).Select'当前单元格
当前单元格的值
ActiveCell.FormulaR1C1 = “UseRow”
复制表单
Windows("spacebom.xls").Activate
Cells.Select
Selection.Copy
Windows("Bomsetup.xls").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Range("A1").Select
复制单元格
Windows("Akiko Resource Budget Plan.xls").Activate
Range("BK71").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book1.xls").Activate
Sheets("Sheet2").Select
ActiveSheet.Paste
当前单元格整栏选择
ActiveCell.EntireColumn.Select、
整栏复制与粘贴
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False
两栏进行交换
Columns("L:L").Select
Selection.Cut
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
Delete:
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Range("B4").Select
Selection.EntireRow.Delete
每列从第k栏开始每5个一列进行排列：
Windows("bomsetup.xls").Activate
Dim Counter As Integer
For Counter = 2 To 1000
Cells(Counter, 11).Select
If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, -5).Select
Selection.EntireRow.Insert
ActiveCell.Offset(-1, 5).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
ActiveCell.Offset(1, -5).Select
ActiveSheet.Paste
End If
Next Counter
字体变色
Range("C3").Select
Selection.Font.ColorIndex = 3
单元格变背景色
Selection.Interior.ColorIndex=3
字体变粗
Range("D4").Select
Selection.Font.Bold = True
在B栏中查找是否有0000后
Columns("B:B").Select
Set findxx = Selection.Find("0000")
If findxx Is Nothing Then
在B栏中查找0000后，向左移动一格
Columns("B:B").Select
Selection.Find(What:="0000", After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, MatchByte:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Select
在c栏中找到N/a后用******替代
Columns("C:C").Select
Selection.Replace What:="n/a", Replacement:="******", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
排序
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("C2") _ , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, SortMethod:=xlStroke, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal
自动塞选
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=10 ‘取消赛选第10栏
Selection.AutoFilter Field:=10, Criteria1:="<>#N/A", Operator:=xlAnd ‘ 第10栏选择非#N/A
自动运行Form
Private Sub Workbook_Open()
你的窗体.Show
End Sub
调整宽度
Columns("L:L").EntireColumn.AutoFit
代表单元格区域"A1:J10"
Range(Cells(1,1),Cells(10,10))代表单元格区域"A1:J10"
区分颜色并删除
Sub FilterColor()
Dim UseRow, AC
UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row
AC = ActiveCell.Column
For i = 1 To UseRow
If Cells(i, AC).Interior.ColorIndex <> ActiveCell.Interior.ColorIndex Then
Cells(i, AC).EntireRow.delete
End If
Next
End If
End Sub
依次打开选定数据夹中的xls 文件
Sub aa()
Dim myDialog As , o Object, strName As String, n As Integer Dim FSO As Object, myFolder As Object, myFiles As Object Dim y
Set myDialog = Application.(mso)
n = 1
With myDialog
If .Show <> -1 Then Exit Sub
Set FSO = CreateObject("Scripting.")
Set myFolder = FSO.GetFolder(.Initial)
Set myFiles = myFolder.Files
For Each o myFiles
strName = UCase(o)
strName = VBA.Right(strName, 3)
If strName = "XLS" Then
y = o
Workbooks.open
n = n + 1
End If
Next
End With
End Sub
SUM 变量引用
Dim nRow1, nRow2 As Integer
Dim nCol As Integer
nRow1 = 2
nRow2 = 11
nCol = 4
Range("d12").Formula = "=sum(d" & nRow1 & ":d" & nRow2 & ")" 或者ActiveCell.FormulaR1C1 = "=SUM(R[-1]C:R[-" & J & "]C)"
XlDirection 可为XlDirection 常量之一。
xlDown
xlToRight
xlToLeft
xlUp
示例
本示例选定包含单元格B4 的区域中B 列顶端的单元格。
Range("B4").End(xlUp).Select
本示例选定包含单元格B4 的区域中第4 行尾端的单元格。
Range("B4").End(xlToRight).Select
从单元格B4 延伸至第四行最后一个包含数据的单元格。
Range("B4", Range("B4").End(xlToRight)).Select
引用单元格的值
Dim xxx
xxx = Workbooks("condition.xls").Worksheets("Sheet1").Range("A1").Value
加上格线
Sub open()
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
End With
End Sub
依次打开指定活页夹中的文件
Sub open()
Dim x As Object
Dim f, fs, i, ofile
Set x = CreateObject("Scripting.")
Set f = x.GetFolder("D:\test")
Set fs = f.Files
For Each o fs
Workbooks.Open
Next
End Sub
得到文件名
Dim getlen, GetFile
getlen = Len(Src) ’the l ength of the name
GetFile = Mid(o, 1, getlen - 4) ‘deduct the last four bytes
所在sheet最后一行
UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Dim i As Integer
Dim myarr
myarr = Array(opath1, opath2, opath3, opath4, opath5, dpath1, dpath2, dpath3, dpath4, dpath5) For i = 0 To 4
mypath = myarr(i) ' 指定路径。
Next
depath = “D:\” ' 指定路径。
myname = Dir(depath, vbDirectory) ' 找寻第一项。
Do While myname <> "" ' 开始循环。
' 跳过当前的目录及上层目录。
If myname <> "." And myname <> ".." Then
dnum = dnum + 1
End If
myname = Dir ' 查找下一个目录。
Loop
显示C:\ 目录下的名称。
MyPath = "c:\" ' 指定路径。
MyName = Dir(MyPath, vbDirectory) ' 找寻第一项。
Do While MyName <> "" ' 开始循环。
' 跳过当前的目录及上层目录。
If MyName <> "." And MyName <> ".." Then
' 使用位比较来确定MyName 代表一目录。
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
Debug.Print MyName ' 如果它是一个目录，将其名称显示出来。
End If
End If
MyName = Dir ' 查找下一个目录。
Loop
Sub 统计显示所浏览的文件夹中某类文件的数量及文件名()
Application.DisplayAlerts = False
For zzzzz = 1 To 5
jjjjj = Workbooks("Book4").Sheets(1).Cells(zzzzz, 1)
Set X = CreateObject("Scripting.")
Set F = X.GetFolder(jjjjj)
Set FS = F.subfolders
For Each o FS
i = i + 1
Cells(i, 1) = ofile & "\ZW"
Next
For j = 1 To i
Set X = CreateObject("Scripting.")
eee = Sheets("sheet1").Cells(j, 1)
Set F = X.GetFolder(eee)
Set FS = F.Files
For Each o FS
y = y + 1
Cells(y, 1) = o
Next
y = 0
Next
For k = 1 To i
Sheets(k).Select
Cells(1, 2).Select
Cells(1, 2) = Application.CountA(Range(Cells(1, 1), Cells(5000, 1))) Cells(1, 3) = Cells(Cells(1, 2), 1)
Cells(1, 4) = Left(Right(Cells(1, 3), 8), 4) - Cells(1, 2)
If Cells(1, 4) <> 0 Then ActiveSheet.Tab.ColorIndex = 3
Z = Z + Cells(1, 4)
Next
MsgBox Z
selectioon.Copy
For ccccc = 1 To i
Sheets(1).Delete
Next
Sheets(1).Cells.Clear
i = 0
Z = 0
Next
End Sub
xxx = https://www.doczj.com/doc/f24976243.html,
ActiveSheet.ChartObjects(xxx).Select
ActiveChart.SetSourceData Source:=Range("A3:F16")
COPY一栏到多栏
Rows(1).Copy Destination:=.Rows("" & SP + 1 & ":" & SP + Bomrtqty & "")
For i = 1 To ActiveSheet.ChartObjects.Count
MsgBox ActiveSheet.ChartObjects(i).Name
Next
ActiveSheet.ChartObjects(1).Activate
ActiveSheet.ChartObjects("Chart 1").Activate
==============
定制模块行为
(1) Option Explicit '强制对模块内所有变量进行声明
Option Private Module '标记模块为私有，仅对同一工程中其它模块有用，在宏对话框中不显示Option Compare Text '字符串不区分大小写
Option Base 1 '指定数组的第一个下标为1
(2) On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
(3) On Error GoTo ErrorHandler '当错误发生时跳转到过程中的某个位置
(4) On Error GoTo 0 '恢复正常的错误提示
(5) Application.DisplayAlerts=False '在程序执行过程中使出现的警告框不显示
(6) Application.ScreenUpdating=False '关闭屏幕刷新
Application.ScreenUpdating=True '打开屏幕刷新
(7) Application.Enable.CancelKey=xlDisabled '禁用Ctrl+Break中止宏运行的功能
工作簿
(8) Workbooks.Add() '创建一个新的工作簿
(9) Workbooks(“book1.xls”).Activate '激活名为book1的工作簿
(10) ThisWorkbook.Save '保存工作簿
(11) ThisWorkbook.close '关闭当前工作簿
(12) ActiveWorkbook.Sheets.Count '获取活动工作薄中工作表数
(13) https://www.doczj.com/doc/f24976243.html, '返回活动工作薄的名称
(14) https://www.doczj.com/doc/f24976243.html, ‘返回当前工作簿名称
ThisWorkbook.FullName ‘返回当前工作簿路径和名称
(15) ActiveWindow.EnableResize=False ‘禁止调整活动工作簿的大小
(16) Application.Window.Arrange xlArrangeStyleTiled ‘将工作簿以平铺方式排列
(17) ActiveWorkbook.WindowState=xlMaximized ‘将当前工作簿最大化
Dim Found, MyObject, MyCollection
Found = False ' 设置变量初始值。
For Each MyObject In MyCollection ' 对每个成员作一次迭代。
If MyObject.Text = "Hello" Then ' 如果Text 属性值等于“Hello”。
Found = True ' 将变量Found 的值设成True。
Exit For ' 退出循环。
End If
Next