【VBA】总结

变量定义

数组

Dim arr() As String

arr = Split("A,B,C,D,E,F,G", ",")

'1、按编号(标)写入和读取

Sub t1() '写入一维数组

Dim x As Integer

Dim arr(1 To 10)

arr(2) = 190

arr(10) = 5

End Sub

Sub t2() '向二维数组写入数据和读取

Dim x As Integer, y As Integer

Dim arr(1 To 5, 1 To 4)

For x = 1 To 5

For y = 1 To 4

arr(x, y) = Cells(x, y)

Next y

Next x

MsgBox arr(3, 1)

End Sub

'2、动态数组

Sub t3()

Dim arr()

Dim row

row = Sheets("sheet2").Range("a65536").End(xlUp).row - 1

ReDim arr(1 To row)

For x = 1 To row

arr(x) = Cells(x, 1)

Next x

Stop

End Sub

'3、批量写入

Sub t4() '由常量数组导入

Dim arr

arr = Array(1, 2, 3, "a")

Stop

End Sub

Sub t5() '由单元格区域导入

Dim arr

arr = Range("a1:d5")

Stop

End Sub

Integer(%)

Long(&)

Single(!)

Double(#)

Currency(@)

String($)

Object

Shape(形状图片文本框)

Rem 循环Sheet1中的所有形状图片文本框

Sub Sh()

Dim m As Shape

For Each m In Sheet1.Shapes

Sheet1.Select

r = m.TopLeftCell.Row ‘图片所在行

c = m.TopLeftCell. Column ‘图片所在列

Debug.Print r

Debug.Print c

Debug.Print m.Top

Debug.Print m.Left

Debug.Print m.Height

Debug.Print m.Width

End Sub

TopLeftCell 左上角所在的单元格

BottomRightCell 右下角所在的单元格

Range

Dim rng As Range

程序语句

Private（定义私有过程）

Private Sub Main()

End Sub

If

IIf函数

Range("a3") = IIf (Range("a1") <= 0, "负数或零", "负数")

Select Casse

Sub select区间判断()

Select Case Range("a2").Value

Case 0 To 1000

Range("b2") = 0.01

Case 1001 To 3000

Range("b2") = 0.03

Case Is > 3000

Range("b2") = 0.05

End Select

End Sub

Select Case Sheet1.Range("A1")

Case "A"

Sheet1.Range("A3") = "联想"

Case "B"

Sheet1.Range("A3") = "华硕"

Case "C"

Sheet1.Range("A3") = "惠普"

Case "D"

Sheet1.Range("A3") = "IBM"

Case "E"

Sheet1.Range("A3") = "三星"

Case Else

Sheet1.Range("A3") = "不知道"

End Select

For…Next

Exit For

For Each…Next

Sub rg3()

Dim rg as range

For each rg in Range(“D2:D18”)

Rg = rg.offset(0,-1) * rg.pffset(0,-2)

Next rg

End sub

Do while

Dim i As Integer

i = 1

rem 循环 10 次数

Do While i <= 10 条件成立则运行下面的语句，否则跳过

Debug.Print i

i = i + 1

Rem If i=2 Then Exit Do

Loop

Wend

Do loop

注意：易造成死循环

Sub do1()

Dim x As Integer

x = x + 1

Debug.Print x

Loop Until x = 18

End Sub

Goto

Sub t1()

Dim x as integer

Dim sr

100:

Sr=application.inputbox(“请输入数字,”输入提示”)

If len(st)=0 or len(sr)=5 goto 100

End sub

Gosub Return

On error resume next 遇到错误，跳过继续执行下一句

使用 on error goto 0 可以使后面的程序取消On error resume next的作用

Err.Number

On error goto 出现错误时跳到直顶的行数

符号

+

-

*

/

Mod（取余）

字符串换行

& Chr(10) &

:

如果两句话本来是写在两排，但是这两句话很短的话就可以把他写在一行上面，中间用冒号连接。这样是为了看起来简洁一些。

:=

表示命名参数

对象

Application

Workbook

Dim oWB As Workbook

Set oWB = Excel.Workbooks.Open(sFilePath)

Workbooks.Open Filename:="C:UsersAdministratorDesktopVBA.xlsx", WriteResPassword:="123"

str = "C:Users2055Desktopopen测试2019.xlsm"

Set Wb = Workbooks.Open(str, , False, , , "2016")

工作表

'1 判断A工作表文件是否存在

Sub s1()

Dim X As Integer

For X = 1 To Sheets.Count

If Sheets(X).Name = "A" Then

MsgBox "A工作表存在"

Exit Sub

End If

MsgBox "A工作表不存在"

End Sub

'2 excel工作表的插入

Sub s2()

Dim sh As Worksheet

Set sh = Sheets.Add

sh.Name = "模板"

sh.Range("a1") = 100

End Sub

'3 excel工作表隐藏和取消隐藏

Sub s3()

Sheets(2).Visible = True

End Sub

'4 excel工作表的移动

Sub s4()

Sheets("Sheet2").Move before:=Sheets("sheet1") 'sheet2移动到sheet1前面

Sheets("Sheet1").Move after:=Sheets(Sheets.Count) 'sheet1移动到所有工作表的最后面

End Sub

'5 excel工作表的复制

Sub s5() '在本工作簿中

Dim sh As Worksheet

Sheets("模板").Copy before:=Sheets(1)

Set sh = ActiveSheet

sh.Name = "1日"

sh.Range("a1") = "测试"

End Sub

'6 excel工作表的复制

Sub s6() '另存为新工作簿

Dim wb As Workbook

Sheets("模板").Copy

Set wb = ActiveWorkbook

wb.SaveAs ThisWorkbook.Path & "/1日.xls"

wb.Sheets(1).Range("b1") = "测试"

wb.Close True

End Sub

'7 保护工作表

Sub s7()

Sheets("sheet2").Protect "123"

End Sub

Sub s8() '判断工作表是否添加了保护密码

If Sheets("sheet2").ProtectContents = True Then

MsgBox "工作簿保护了"

Else

MsgBox "工作簿没有添加保护"

End If

End Sub

'8 工作表删除

Sub s9()

Application.DisplayAlerts = False

Sheets("模板").Delete

Application.DisplayAlerts = True

End Sub

'9 工作表的选取

Sub s10()

Sheets("sheet2").Select

End Sub

Range

rng.Top ‘位置

rng. Left ‘位置

rng. Height ‘高度

rng. Width ‘宽度

Option Explicit

'1 表示一个单元格(a1)

Sub s()

Range("a1").Select

Cells(1, 1).Select

Range("A" & 1).Select

Cells(1, "A").Select

Cells(1).Select

[a1].Select

End Sub

'2 表示相邻单元格区域

Sub d() '选取单元格a1:c5

' Range("a1:c5").Select

' Range("A1", "C5").Select

' Range(Cells(1, 1), Cells(5, 3)).Select

'Range("a1:a10").Offset(0, 1).Select

Range("a1").Resize(5, 3).Select

End Sub

'3 表示不相邻的单元格区域

Sub d1()

Range("a1,c1:f4,a7").Select

'Union(Range("a1"), Range("c1:f4"), Range("a7")).Select

End Sub

Sub dd() 'union示例

Dim rg As Range, x As Integer

For x = 2 To 10 Step 2

If x = 2 Then Set rg = Cells(x, 1)

Set rg = Union(rg, Cells(x, 1))

Next x

rg.Select

End Sub

'4 表示行

Sub h()

'Rows(1).Select

'Rows("3:7").Select

'Range("1:2,4:5").Select

Range("c4:f5").EntireRow.Select

End Sub

'5 表示列

Sub L()

' Columns(1).Select

' Columns("A:B").Select

' Range("A:B,D:E").Select

Range("c4:f5").EntireColumn.Select '选取c4:f5所在的行

End Sub

'6 重置坐标下的单元格表示方法

Sub cc()

Range("b2").Range("a1") = 100

End Sub

'7 表示正在选取的单元格区域

Sub d2()

Selection.Value = 100

End Sub

Cells

事件

工作簿

ThisWorkbook 当前vba代码所在的工作簿

ActiveWorkbook 活动的工作簿

工作表

开关

Rem屏幕更新开关

Application.ScreenUpdating = False '关闭更新过程

Application.ScreenUpdating = true '打开更新过程

Rem键盘输入开关

Application.Interactive = False '关闭输入

Application.Interactive = True '打开输入

Rem 加载宏行为

Workbook.IsAddin= True '加载宏

Workbook.IsAddin= False '不加载宏

Rem提示错误信息

Application.DisplayAlerts = false ‘不提示错误信息

Application.DisplayAlerts = true ‘提示错误信息

技巧

Rem 全屏显示

Private Sub CommandButton1_Click()

If CommandButton1.Caption = "全屏显示" Then

Application.DisplayFullScreen = True

CommandButton1.Caption = "取消全屏"

Else

Application.DisplayFullScreen = False

CommandButton1.Caption = "全屏显示"

End If

End Sub

Rem 全屏显示2

Private Sub CommandButton1_Click()

If CommandButton1.Caption = "全屏显示" Then

With Application

.DisplayFullScreen = True '基本全屏

.CommandBars(1).Enabled = False '隐藏工作表菜单栏

.CommandBars("Full Screen").Controls(1).OnAction = "Restorewindow"

End With

With ActiveWindow

.DisplayHeadings = False '隐藏行号列号

.DisplayHorizontalScrollBar = False '隐藏滚动条

.DisplayVerticalScrollBar = False '隐藏滚动条

Rem .DisplayWorkbookTabs = False '隐藏工作表标签

End With

CommandButton1.Caption = "取消全屏"

Else

With Application

.DisplayFullScreen = False

.CommandBars(1).Enabled = True

.CommandBars("Full Screen").Reset

End With

With ActiveWindow

.DisplayHeadings = True

.DisplayHorizontalScrollBar = True

.DisplayVerticalScrollBar = True

Rem .DisplayWorkbookTabs = True

End With

CommandButton1.Caption = "全屏显示"

End If

End Sub

Rem遍历所有sheets

For Each sht In ThisWorkbook.Sheets

If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible

Rem文件夹是否存在创建文件夹

Dim fs As Object

Set fs = CreateObject("scripting.filesystemobject")

If fs.Folderexists("E:KK") = False Then fs.CreateFolder "E:KK"

Rem读取txt

Input：以输入方式打开，即读取方式。
Output：以输出方式打开，即写入方式。文件不存在则创建
Append：以追加方式打开，即添加内容到文件末尾。

Rem读文本1

Sub readTxt()

Dim a As Variant

Dim s As String

Open "….txt" For Input As #1

While Not EOF(1)

Line Input #1, s

If InStr(s, "=") Then

a = Split(s, "=")

'Debug.Print a(1)

End If

Wend

Close #1

End Sub

Rem读文本2

Sub main()

Dim muhao As String

Open "D:SMART_E-x64softhtk_CheckSheet_Update设计进行中的评审表.txt" For Input As #1

While Not EOF(1)

Line Input #1, muhao

Debug.Print muhao

Wend

Close #1

End Sub

Rem填写txt

Dim temptxt02 As String

temptxt02 = "D:SMART_E-x64softhtk_input_excel_vbaYouCanEnter.txt"

Open temptxt02 For Output As #2

Print #2, "YouCannotEnter!"

Close #2

Function IsFileExists(ByVal strFileName As String) As Boolean

If Dir(strFileName, 16) <> Empty Then

IsFileExists = True

Else

IsFileExists = False

End If

End Function

Rem复制文件

Dim souf$, desf$

souf = "D: est.xlsx"

desf = "E:vba est.xlsx"

FileCopy souf, desf

Sub 将指定路径下的某一文件复制到另一指定路径下2()

Dim fso As Object, souf$, des$

Set fso = CreateObject("Scripting.FilesyStemObject")

Set fso = Nothing

End Sub

Rem 自定义标题栏

Sub SetCaption()

Application.Caption = "试模问题清单计划查询系统-海泰科持续改进部"

ActiveWindow.Caption = vbNullString

End Sub

Rem合并单元格并居中

Range("B168:B169").Select

Selection.Merge

Selection.HorizontalAlignment = xlCenter

Selection.VerticalAlignment = xlCenter

Rem最大化程序窗口和工作簿

Sub MaximizedWin()

Application.WindowState = xlMaximized

ActiveWindow.WindowState = xlMaximized

End Sub

Rem有内容的最大行

Rem 所有列最大行

Sheets("Sheet1").UsedRange.Rows.Count

Rem A列最大行

Sheets("Sheet1").Range("A" & Cells.Rows.Count).End(xlUp).Row

ThisWorkbook.Sheets(strSheet2).Range("A:A").SpecialCells(xlCellTypeConstants).Count

Rem 数组去重

Dim brr(1 To 300) As String ' brr用来保存不重复值

Dim i1&, j1&

Dim k1& ' k是brr中不重复值个数

' 区域值赋给arr

k1 = 0 ' 最开始没有数据

For i1 = 1 To UBound(arr)

For j1 = 1 To k1 ' 与brr中的每个不重复数据进行比较

If brr(j1) = arr(i1) Then ' arr中的值在brr中已经存在

Exit For ' 跳出内层循环,判断下一个arr中的数据

End If

Next j1

If j1 = k1 + 1 Then ' 内层循环运行到brr中的最后一个数据,这时j=k+1,还没有在brr中找到相等的数据,

k1 = k1 + 1 ' brr中的不重复数+1

brr(k1) = arr(i1) ' 不重复数新增到arr中

End If

Next i1

Dim mmm As Long

Dim i2 As Long

i2 = 4

For mmm = 1 To k1 ' k是brr中不重复值个数

Next mmm

Rem移动图片

ren 选中图片移动到B8

If TypeName(Selection) = "Picture" Then

Selection.Left = [B8].Left

Selection.Top = [B8].Top

End If

Rem判断单元格是否为空

IsEmpty(Worksheets("实际日期").Cells(i, "E").Value) = False

Rem打开或激活工作簿

Function OpenExcel(strPath As String, strFile As String, openType As Boolean)

If Right(strPath, 1) <> "" Then strPath = strPath & "" '最后一位不是就加上

Dim strAllPath As String

strAllPath = strPath + strFile

Dim i As Integer

For i = 1 To Workbooks.Count

If Workbooks(i).Name = strFile Then

Windows(strFile).Activate

Exit Function

End If

Next i

Workbooks.Open strAllPath, ReadOnly:=openType

End Function

Rem 读取未打开的Excel文件内容

Public Function GetCellValue(strPath As String, strFile As String, strSheet As String, strA1 As String)

If Right(strPath, 1) <> "" Then strPath = strPath & "" '最后一位不是就加上

If Dir(strPath & strFile) = "" Then '判断文件是否存在

Err.Raise 12345, "GetCellValue", "NO found file"

Exit Function

End If

GetCellValue = ExecuteExcel4Macro("'" & strPath & "[" & strFile & "]" & strSheet & "'!" & Range(strA1).Address(, , xlR1C1))

Debug.Print "'" & strPath & "[" & strFile & "]" & strSheet & "'!" & Range(strA1).Address(, , xlR1C1)

Rem 一个不带等号的 Microsoft Excel 4.0 宏语言函数。所有引用必须是像 R1C1 这样的字符串。

Rem 如果 String 内包含嵌套的双引号，则必须写两个。例如，要运行宏函数 =MID("sometext",1,4)，String 必须为 “MID(""sometext"",1,4)”。

End Function

Sub CheckClosedFile()

Dim strPath As String

Dim strFile As String

Dim strSheet As String

Dim strResult As String

strPath = "D:SMART_E-x64softhtk_Work_Table"

strFile = "模具台帐181224.xlsx"

strSheet = "2018年"

strResult = GetCellValue(strPath, strFile, strSheet, "A8")

Debug.Print strResult

End Sub

Rem判断文件是否存在

Function IsFileExists(ByVal strFileName As String) As Boolean

Dim objFileSystem As Object

Set objFileSystem = CreateObject("Scripting.FileSystemObject")

If objFileSystem.fileExists(strFileName) = True Then

IsFileExists = True

Else

IsFileExists = False

End If

End Function

Sub Run()

If IsFileExists("D:vbaabc.txt") = True Then

' 文件存在时的处理

MsgBox "文件存在！"

Else

' 文件不存在时的处理

MsgBox "文件不存在！"

End If

End Sub

Sub Run() ‘如果存在则删除

Dim temptxt01 As String

temptxt01 = "D:SMART_E-x64softhtk_input_excel_vba empB.txt"

If IsFileExists(temptxt01) = True Then

Kill temptxt01

End If

Sub Run()

Rem打开关闭Excel

打开：

Workbooks.Open strAllPath

输入密码打开:

Workbooks.Open strAllPath , Password:="1230", ReadOnly:=False

只读方式打开:

Workbooks.Open strAllPath, ReadOnly:=True

保存关闭：

Workbooks.Close SaveChanges:=true

不保存关闭：

Workbooks.Close SaveChanges:=False

Rem 读取定义名称的单元格

ActiveWorkbook.Sheets(2).Range("模具编号").value

Rem 字符串是否包含

用instr函数判断是否包含指定字符，>0表示"含有"

SearchString = "XXpXXpXXPXXP" 被搜索的字符串
SearchChar = "P" 要查找字符串 "P"
MyPos = InStr(SearchString, SearchChar) 返回9
MyPos = InStr(1, SearchString, "W") 返回 0

InStrRev 倒叙

Rem 将工作表中的图形对象另存为图片

Sub savepic()

Dim Shp As Shape

Dim i As Integer

With ActiveSheet

For i = 1 To .Shapes.Count

Set Shp = .Shapes(i)

Shp.Copy

With .ChartObjects.Add(0, 0, Shp.Width, Shp.Height + 5).Chart

.Paste

.Export "C:Users2055Desktop将工作表中的图片另存为文件" & i & ".jpg"

.Parent.Delete

End With

Next i

End With

End Sub

Rem 删除图片

Sub 删除图片()

Dim i As Integer

For i = ActiveSheet.Shapes.Count To 1 Step -1

If ActiveSheet.Shapes(i).TopLeftCell.Row >= 102 Then

ActiveSheet.Shapes(i).Select

Selection.Delete

End If

Next i

End Sub

Rem选择打开文件

Sub abc()

Excel.Application.ScreenUpdating = False

Excel.Application.DisplayAlerts = False '不提示是否保存

Excel.Application.Calculation = xlCalculationManual

'选择路径读取打开法

Dim oWB As Workbook

Dim oWK As Worksheet

Dim oFD As FileDialog

Dim sFilePath As String

Dim iRow As Long

'创建一个选择文件对话框

Set oFD = Excel.Application.FileDialog(msoFileDialogFilePicker)

'声明一个变量用来存储选择的文件名

Dim vrtSelectedItem As Variant

With oFD

'允许选择多个文件

.AllowMultiSelect = True

'使用Show方法显示对话框，如果单击了确定按钮则返回-1。

If .Show = -1 Then

'遍历所有选择的文件

For Each vrtSelectedItem In .SelectedItems

'获取所有选择的文件的完整路径,用于各种操作

sFilePath = vrtSelectedItem

Set oWB = Excel.Workbooks.Open(sFilePath)

With oWB

Set oWK = .Worksheets(1)

With oWK

iRow = .Range("a65536").End(xlUp).Row

'***********************************

'其它操作代码

'***********************************

End With

Excel.Application.Calculation = xlCalculationAutomatic

.Close

End With

Set oWK = Nothing

Set oWB = Nothing

End If

End With

Excel.Application.DisplayAlerts = True

Excel.Application.ScreenUpdating = True

End Sub

Rem路径

Application.ActiveWorkbook.Path   只返回路径
Application.ActiveWorkbook.FullName   返回路径及工作簿文件名
Application.ActiveWorkbook.Name   返回工作簿文件名

Rem 通过配置文件打开excel

Dim strPathAll_X As String

Dim strPath_X As String

Dim strFileName_X As String

Function getPath(strTag As String) ' strDesignPlan

strPathAll_X = "Err"

strPath_X = "Err"

strFileName_X = "Err"

Dim arr() As String

Dim strPathAllTemp As String

Dim MyPos As Integer

Open "\192.168.16.253share设计管理Design data-标准化工具及工具使用技巧1.NX 外挂(最新便于随时升级)D-ALLHTK-x64applicationhtk_public_filelocation.cfg" For Input As #1

While Not EOF(1)

Line Input #1, strPathAllTemp

MyPos = InStr(strPathAllTemp, "=")

If MyPos <> 0 Then

arr = Split(strPathAllTemp, "=")

End If

If arr(0) = strTag Then

strPathAll_X = arr(1)

End If

Wend

Close #1

strPath_X = Left(strPathAll_X, InStrRev(strPathAll_X, ""))

strFileName_X = Right(strPathAll_X, Len(strPathAll_X) - InStrRev(strPathAll_X, ""))

Debug.Print strPathAll_X

Debug.Print strPath_X

Debug.Print strFileName_X

End Function

Sub 判断文件打开状态()

Dim i As Integer '声明变量i为整数，变量应用于后面的循环

For i = 1 To Workbooks.Count '设置变量i在1到“工作簿数量”的区间内进行循环

If Workbooks(i).Name = strFileName_X Then '把第i个工作簿的文件名和给定的“Workbook1.xlsm”相对比，如果相同就执行下一句

' MsgBox "文件已打开" '用对话框显示“文件已打开”

Windows(strFileName_X).Activate

Exit Sub '跳出当前过程

End If

Next i

'MsgBox "文件未打开" '如果程序没有被中止，就说明找不到相同的文件名，该文件未被打开，'而如果找到了相同的文件名程序会在运行该语句之前中止该过程

Workbooks.Open strPathAll_X

End Sub

Sub 打开汇总表()

Call getPath("strDesignPlan")

If strPathAll_X = "Err" Then

MsgBox "找不到设计计划表"

Exit Sub

End If

Call 判断文件打开状态 '打开或者激活工作簿

End Sub

Rem判断是否为日期格式

IsDate(ActiveSheet.Cells(i, "AA")

Rem判断文件（夹）的修改时间

Sub test()

Dim MyStamp As String

MyStamp = Format(FileDateTime("\192.168.16.253share设计管理工程师个人工作统计任务汇报2018-工作统计"), "yyyymmdd")

Debug.Print MyStamp

End Sub

Rem 列出文件夹下文件名

Sub OPIONA() '//函数实例

arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)

For I = 0 To UBound(arr)

MsgBox arr(I)

'Set WB = Workbooks.Open(arr(I))

'你的代码

'WB.Close False

End Sub

'****************************************************************

'功能：查找指定文件夹含子文件夹内所有文件名（含路径）

'函数名： FileAllArr

'参数1： Filename 需查找的文件夹名不含最后的""

'参数2： FileFilter 需要过滤的文件名，可省略，默认为：[*.*]

'参数3： Liwai 剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name

'返回值：一个字符型的数组

'使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)

Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()

Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象

Set Did = CreateObject("Scripting.Dictionary")

Dic.Add (Filename & ""), ""

I = 0

Do While I < Dic.Count

Ke = Dic.keys '开始遍历字典

MyName = Dir(Ke(I), vbDirectory) '查找目录

Do While MyName <> ""

If MyName <> "." And MyName <> ".." Then

If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录

Dic.Add (Ke(I) & MyName & ""), "" '就往字典中添加这个次级目录名作为一个条目

End If

MyName = Dir '继续遍历寻找

Loop

I = I + 1

Loop

I = 0

Dim arrx() As String

For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例

MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx

Do While MyFileName <> ""

If MyFileName <> Liwai Then '排除例外文件

ReDim Preserve arrx(I)

arrx(I) = Ke & MyFileName

I = I + 1

End If

MyFileName = Dir

Loop

FileAllArr = arrx

End Function

'****************************************************************

Rem 列出文件夹下所有xlsx文件名

Dim MyFile, MyPath, MyName

Dim m As Integer

MyPath = "\192.168.16.253share设计管理工程师个人工作统计任务汇报2019-工作统计" ' 指定路径。

MyFile = Dir(MyPath & "*.xlsx")

Do Until Len(MyFile) = 0

m = m + 1

Cells(m, 1) = MyFile

MyFile = Dir

Loop

Rem 取消筛选

Sub 取消筛选()

Dim ws As Worksheet

Dim myAutoFilter As AutoFilter

Dim myRange As Range

Set ws = ActiveSheet

Set myAutoFilter = ws.AutoFilter

If Not myAutoFilter Is Nothing Then

myAutoFilter.Range.AutoFilter

Else

MsgBox "没有自动筛选"

End If

Set myRange = Nothing

Set myAutoFilter = Nothing

Set ws = Nothing

End Sub

Rem 颜色

单元格底色

Cells(a(0), "L").Interior.Color = 16738047

替换为空格

Value = Replace(strBeforeYesterday_Eng, "#", " ")

Rem工作表中有数据的最大列：

ActiveCell.SpecialCells(xlLastCell).Column

Rem sheet所在的workbook

.Parent

Rem 获取8位日期格式

Sub MoveFile()

Dim strDate As String

strDate = Format(Date, "YYYYMMDD")

End Sub

Rem 是否合并单元格，获取合并单元格的值

If .Range("J" & i).MergeCells = True Then

MsgBox "包含合并单元格”"

Else

MsgBox "不包含合并单元格"

End If

.MergeArea(1).Value

Rem 全路径获取文件名

Mid(sFilePath_x, InStrRev(sFilePath_x, "") + 1, 100)

Rem 文件夹大小

Option Explicit

Sub 判断文件夹是否为空()

Dim f As String

f = "C:Users2055Desktop创建文件夹新建文件夹"

Debug.Print fldsize(f)

End Sub

Function fldsize(path$)

Dim fso, fld

Set fso = CreateObject("scripting.filesystemobject")

Set fld = fso.getfolder(path)

fldsize = fld.Size

'fldsize = Format(fld.Size, "0,0,0") & " Byte"

End Function

Rem 定义常量

Public Const strSheet2 As String = "跟踪表"

Rem 距离今天有几天

If IsDate(ActiveSheet.Cells(2, iii).Value) Then

Endif

Day = DateDiff("d", ActiveSheet.Cells(2, iii).Value, Date)

Rem 读取文件修改时间

Sub 读取文件修改时间()

Dim PicName As String

PicName = "D:SMART_E-x64softhtk_input_excel_vbahtk_input_excel_vba.exe"

Debug.Print Format(FileDateTime(PicName), "yyyymmdd")

End Sub

Rem 更新进度

Application.StatusBar = "已完成：" & Format((i - 3) / (2000 - 3), "0.00%")

Rem 延时

sub delay(T as single)
dim T1 as single
t1=timer
do
doevents
loop while timer-t1<t
end sub

Rem 名称管理器操作

‘读值

Dim WhoIsOpening As String

WhoIsOpening = Mid(ActiveWorkbook.Names("WhoIsOpening").Value, 2, 10000)

Debug.Print WhoIsOpening

Rem 提示谁打开了此文件

Private Sub Workbook_Open()

If ThisWorkbook.ReadOnly Then

Dim WhoIsOpening As String

WhoIsOpening = Mid(ActiveWorkbook.Names("WhoIsOpening").Value, 2, 10000)

MsgBox WhoIsOpening & "正在使用。", vbExclamation, "使用提示"

Else

ActiveWorkbook.Names.Add Name:="WhoIsOpening", RefersToR1C1:=Application.UserName, Visible:=False

ActiveWorkbook.Save

End If

End Sub

Rem 获取当前电脑桌面地址

Sub 获取当前电脑桌面地址()
MsgBox "当前电脑桌面地址是：" & Environ("USERPROFILE") & "桌面"
End Sub

Rem Environ系统环境变量函数大全

Public Sub Get_Environ()

Debug.Print Environ("Windir") 'c:windows Windows 目录

Debug.Print Environ("ProgramFiles") 'c:ProgramFiles 应用程序文件夹

Debug.Print Environ("UserProfile") 'C:Documents and SettingsAdministrator 用户配置文件目录

Debug.Print Environ("ALLUSERSPROFILE") '局部返回所有“用户配置文件”的位置。

Debug.Print Environ("APPDATA") '局部返回默认情况下应用程序存储数据的位置。

Debug.Print Environ("COMPUTERNAME") '系统返回计算机的名称。

Debug.Print Environ("COMSPEC") '系统返回命令行解释器可执行程序的准确路径。

Debug.Print Environ("HOMEDRIVE") '系统返回连接到用户主目录的本地工作站驱动器号。基于主目录值的设置。用户主目录是在“本地用户和组”中指定的。

Debug.Print Environ("HOMEPATH") '系统返回用户主目录的完整路径。基于主目录值的设置。用户主目录是在“本地用户和组”中指定的。

Debug.Print Environ("NUMBER_OF_PROCESSORS") '系统指定安装在计算机上的处理器的数目。

Debug.Print Environ("OS") '系统返回操作系统的名称。Windows 2000 将操作系统显示为 Windows_NT。

Debug.Print Environ("PATH") '系统指定可执行文件的搜索路径。

Debug.Print Environ("PATHEXT") '系统返回操作系统认为可执行的文件扩展名的列表。

Debug.Print Environ("PROCESSOR_ARCHITECTURE") '系统返回处理器的芯片体系结构。值: x86，IA64。

Debug.Print Environ("PROCESSOR_LEVEL") '系统返回计算机上安装的处理器的型号。

Debug.Print Environ("PROCESSOR_LEVEL") '系统返回处理器的版本号。

Debug.Print Environ("SYSTEMDRIVE") '系统返回包含 Windows XP 根目录（即系统根目录）的驱动器。

Debug.Print Environ("SYSTEMROOT") '系统返回 Windows XP 根目录的位置。

Debug.Print Environ("TEMP") 'and %TMP") '系统和用户返回对当前登录用户可用的应用程序所使用的默认临时目录。有些应用程序需要 TEMP，而其它应用程序则需要 TMP。

Debug.Print Environ("USERDOMAIN") '局部返回包含用户帐户的域的名称。

Debug.Print Environ("USERNAME") '局部返回当前登录的用户的名称。

End Sub

Rem Environ系统环境变量函数最全

Sub EnumSEVars()

Dim strVar As String

Dim i As Long

For i = 1 To 255

strVar = VBA.Environ$(i)

If LenB(strVar) = 0& Then Exit For

Debug.Print strVar

End Sub

excel如何在一个excel中用宏运行另一个excel中的宏？

Application.Run "文件名全称+!+宏名称"

Rem 先判断后保存

If Not ThisWorkbook.ReadOnly Then ThisWorkbook.Save

Rem 获取文件名填入一个单元格中

Sub aa()

Range("A1") = 提取文件文件名("C:Users2055Desktop1111list")

End Sub

Function 提取文件文件名(myPath As String) As String

Dim strContent As String

Dim myTxt As String

myTxt = Dir(myPath, 31)

Do While myTxt <> ""

On Error Resume Next

If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then

If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then '文件夹

strContent = strContent & myTxt & Chr(10)

Else '文件

strContent = strContent & myTxt & Chr(10)

End If

myTxt = Dir

Loop

提取文件文件名 = Left(strContent, Len(strContent) - 1)

End Function

vba函数

len 字符个数

left

right

mid

InStr查找字符串，从前往后

InStrRev查找字符串从后往前

文件操作

删除空文件夹

RmDir "C:Mail" 删除空文件夹

删除文件夹下所有txt文件（不包含子文件夹中的）

Kill "D:Mail*.txt" 删除文件夹下所有txt文件（不包含子文件夹中的）

'1 判断A.Xls文件是否存在

If Dir("F:111", vbDirectory) <> "" Then

MsgBox "文件夹存在"

End If

If Not Dir(全路径, vbDirectory) = vbNullString Then

文件或文件夹是否存在 = True '不存在

End If

Sub W1()

If Len(Dir("d:/A.xls")) = 0 Then

MsgBox "A文件不存在"

Else

MsgBox "A文件存在"

End If

End Sub

'2 判断A.Xls文件是否打开

Sub W2()

Dim X As Integer

For X = 1 To Windows.Count

If Windows(X).Caption = "A.XLS" Then

MsgBox "A文件打开了"

Exit Sub

End If

End Sub

'3 excel文件新建和保存

Sub W3()

Dim wb As Workbook

Set wb = Workbooks.Add

wb.Sheets("sheet1").Range("a1") = "abcd"

wb.SaveAs "D:/B.xls"

End Sub

'4 excel文件打开和关闭

Sub w4()

Dim wb As Workbook

Set wb = Workbooks.Open("D:/B.xls")

MsgBox wb.Sheets("sheet1").Range("a1").Value

wb.Close False

End Sub

'5 excel文件保存和备份

Sub w5()

Dim wb As Workbook

Set wb = ThisWorkbook

wb.Save

wb.SaveCopyAs "D:/ABC.xls"

End Sub

'6 excel文件复制和删除

Sub W6()

FileCopy "D:/ABC.XLS", "E:/ABCd.XLS"

Kill "D:/ABC.XLS"

End Sub

HTK_h 头文件模块

<![if !supportLists]> <![endif]>读config配置文件

Option Explicit

Dim Co As Object

Private Sub 更新_Click()

Dim datebase As String

datebase = "\192.168.16.253Std$database模具信息数据库.xlsx"

If Dir(datebase, vbDirectory) = "" Then

MsgBox "错误：数据库文件不存在!"

Exit Sub

End If

If 读取cfg Then Exit Sub

ThisWorkbook.Sheets(Co("表名")).Select

On Error Resume Next

ActiveSheet.ShowAllData

Dim iMax As Integer

iMax = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row

Dim i As Integer

For i = Co("起始行") To iMax

Next i

End Sub

Function 读取cfg() As Boolean

Dim strcfg As String

strcfg = ThisWorkbook.Path & "config" & Replace(ThisWorkbook.Name, ".xlsm", ".cf1g")

If Dir(strcfg, vbDirectory) = "" Then

MsgBox "错误：配置文件不存在!" & Chr(10) & strcfg

读取cfg = True

Exit Function

End If

Set Co = CreateObject("Scripting.Dictionary")

Dim a As Variant

Dim s As String

Open strcfg For Input As #1

While Not EOF(1)

Line Input #1, s

If Len(s) > 2 Then

If Not InStr(s, "##") Then

If InStr(s, "=") Then

a = Split(s, "=")

Co.Add a(0), a(1)

'Debug.Print a(0) & "=" & a(1)

End If

Wend

Close #1

End Function

蓝色幻想 VBA 课程80课

1. 复制单元格

Range("A1").Copy Destination:= Range("A2")

Range("A1").Copy Range("A2")

2. 牛排.做熟的程度:=七成熟