【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

Next

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

Do

  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

      Next

      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

Next

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

        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

            Next

        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

Next

 

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

            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

    Next

    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

        Next

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

        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

      Next

    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

                End If

            End If

    Wend

    Close #1

End Function

 

 

蓝色幻想 VBA 课程80课

1. 复制单元格

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

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

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

3.