VBA 语句汇总.doc

程序错误继续执行On Error Resume Next屏幕不更新Application.ScreenUpdating = FalseApplication.ScreenUpdating = True警示为假Application.DisplayAlerts = False关掉文件不保存Windows(oFile.Name).ActivateActiveWorkbook.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 Filename:=D:BOM Producecarrier.xls, FileFormat:= _ xlNormal, Password:=, WriteResPassword:=, ReadOnlyRecommended:=False _ , CreateBackup:=False增加一个表单，获取nameSheets.Addx = ActiveSheet.NameSheets(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:=xlToRightDelete:Rows(2:2).SelectSelection.Delete Shift:=xlUpRange(B4).SelectSelection.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).SelectSet 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自动运行FormPrivate Sub Workbook_Open()你的窗体.ShowEnd Sub调整宽度Columns(L:L).EntireColumn.AutoFit代表单元格区域A1:J10Range(Cells(1,1),Cells(10,10)代表单元格区域A1:J10区分颜色并删除SubFilterColor() DimUseRow,AC UseRow=Cells.SpecialCells(xlCellTypeLastCell).Row AC=ActiveCell.Column Fori=1ToUseRow IfCells(i,AC).Interior.ColorIndexActiveCell.Interior.ColorIndexThen Cells(i,AC).EntireRow.deleteEndIf Next EndIf EndSub依次打开选定数据夹中的xls 文件Sub aa()Dim myDialog As FileDialog, oFile As Object, strName As String, n As IntegerDim FSO As Object, myFolder As Object, myFiles As ObjectDim ySet myDialog = Application.FileDialog(msoFileDialogFolderPicker)n = 1With myDialogIf .Show -1 Then Exit SubSet FSO = CreateObject(Scripting.FileSystemObject)Set myFolder = FSO.GetFolder(.InitialFileName)Set myFiles = myFolder.FilesFor Each oFile In myFilesstrName = UCase(oFile.Name)strName = VBA.Right(strName, 3)If strName = XLS Theny = oFile.NameWorkbooks.open Filename:=yn = n + 1End IfNextEnd WithEnd SubSUM 变量引用Dim nRow1, nRow2 As IntegerDim nCol As IntegernRow1 = 2nRow2 = 11nCol = 4Range(d12).Formula = =sum(d & nRow1 & :d & nRow2 & )或者ActiveCell.FormulaR1C1 = =SUM(R-1C: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 openfileonebyone() 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 openfileonebyone() Dim x As Object Dim f, fs, i, ofile Set x = CreateObject(Scripting.FileSystemObject) Set f = x.GetFolder(D:test) Set fs = f.Files For Each ofile In fs Workbooks.Open Filename:=ofile Next End Sub得到文件名Dim getlen, GetFilegetlen = Len(SrcFile.Name) the length of the nameGetFile = Mid(ofile.Name, 1, getlen - 4) deduct the last four bytes所在sheet最后一行UseRow=Cells.SpecialCells(xlCellTypeLastCell).Row Dim i As IntegerDim myarrmyarr = Array(opath1, opath2, opath3, opath4, opath5, dpath1, dpath2, dpath3, dpath4, dpath5) For i = 0 To 4mypath = myarr(i) 指定路径。Nextdepath = “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 ThenDebug.Print MyName 如果它是一个目录，将其名称显示出来。 End If End If MyName = Dir 查找下一个目录。LoopSub 统计显示所浏览的文件夹中某类文件的数量及文件名()Application.DisplayAlerts = FalseFor zzzzz = 1 To 5jjjjj = Workbooks(Book4).Sheets(1).Cells(zzzzz, 1)Set X = CreateObject(Scripting.FileSystemObject)Set F = X.GetFolder(jjjjj)Set FS = F.subfoldersFor Each ofile In FSi = i + 1Cells(i, 1) = ofile & ZWNextFor j = 1 To iSheets.AddSet X = CreateObject(Scripting.FileSystemObject)eee = Sheets(sheet1).Cells(j, 1)Set F = X.GetFolder(eee)Set FS = F.FilesFor Each ofile In FSy = y + 1Cells(y, 1) = ofile.NameNexty = 0NextFor k = 1 To iSheets(k).SelectCells(1, 2).SelectCells(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 = 3Z = Z + Cells(1, 4)NextMsgBox Zselectioon.CopyFor ccccc = 1 To iSheets(1).DeleteNextSheets(1).Cells.Cleari = 0Z = 0NextEnd Sub添加图表 xxx = ActiveSheet.Shapes.AddChart.Name ActiveSheet.ChartObjects(xxx).SelectActiveChart.SetSourceData Source:=Range(A3:F16)COPY一栏到多栏 Rows(1).Copy Destination:=.Rows( & SPfileexistcount + 1 & : & SPfileexistcount + 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 当错误发生时