VBA代码碎片

1.获取用户桌面路径

Sub getDesktop()
' 声明变量
Dim WshShell As Object
Dim desktop  As String

'创建shell对象
Set WshShell = CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")

' 输出结果
MsgBox desktop

End Sub

2.判断文件或文件夹是否存在

Public Function FileFolderExists(strFullPath As String) As Boolean
 
    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
    On Error GoTo 0
 
End Function

判断文件夹是否存在：
Public Sub TestFolderExistence()
 
    If FileFolderExists("c:/windows/") Then 
        MsgBox "指定的文件夹存在！" 
    Else 
        MsgBox "指定的文件夹不存在！" 
    End If
 
End Sub

判断文件是否存在：
Public Sub TestFileExistence()
 
    If FileFolderExists("d:/Book1.xls") Then 
        MsgBox "指定的文件存在！" 
    Else 
        MsgBox "指定的文件不存在！" 
    End If
 
End Sub

3.创建目录,删除目录,切换目录

Sub getDesktop()
' 声明变量
Dim WshShell As Object
Dim desktop  As String
Dim cur_dir

' 当前文件路径
cur_dir = CurDir$
MsgBox "当前文件夹是:" & cur_dir


'创建shell对象
Set WshShell = CreateObject("WScript.Shell")
' 获取桌面路径
desktop = WshShell.SpecialFolders("Desktop")

ChDir desktop ' 切换路径
cur_dir = CurDir$
MsgBox "当前文件夹是:" & cur_dir


' 在桌面新建文件夹(不存在就创建)
Dim file_path As String

file_path = desktop & "\wyh_files\wyh_test_open.txt"
Debug.Print file_path

Dim result

result = Dir(file_path) '判断文件是否存在

If Dir(file_path) = "" Then
Debug.Print "文件不存在"
MkDir (desktop & "\mail")
Else
MsgBox desktop & "\wyh_files" & "路径存在!!!"
If Dir(desktop & "\mail") = "" Then
MsgBox "谢谢!!!"
MkDir (desktop & "\mail")

Else
RmDir (desktop & "\mail")
End If

End If
End Sub

4.删除行一般从下往上删(避免漏处理)

Sub writeCell()
Dim i As Integer

On Error GoTo baseError
For i = 50 To 1 Step -1
    ' 处理性别
    If Range("d" & i) = "F" Then '
    Range("c" & i) = "先生"
    ElseIf Range("d" & i) = "M" Then
    Range("c" & i) = "女士"
    End If
    
    ' 删除姓名为空的行
    If Range("a" & i) = "" Then
        Range("a" & i).Select
        Selection.EntireRow.Delete
    End If
    
    
Next
baseError:
     On Error GoTo 0

End Sub

5.新建文本并写入数据

Sub createFile()

' 声明变量
Dim WshShell As Object
Dim desktop  As String
Dim fileName As String
Dim file_path As String

'创建shell对象
Set WshShell = CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")

'定义新建的文本存放路径和文本名
fileName = "runJob.sh"
file_path = desktop & "\" & fileName


' 以读写方式打开文件，每次写内容都会覆盖原先的内容
Open file_path For Output As #1

' 一行一行往文本里写入数据
Print #1, "#!/bin/bash"
Print #1, "echo 'hello world!!!'"
Close #1 '关闭文本


End Sub

6.获取激活工作表名字

Sub getName()
Dim s As String

s = ActiveSheet.Name
MsgBox s

End Sub

7.工作簿操作(打开,新建,另存为)

Sub workSheetOperation()

Dim ssheet As Worksheet

Application.ScreenUpdating = False  ' 关闭屏幕更新
Application.DisplayAlerts = False   ' 关闭弹窗

' 删除工作表
For Each ssheet In Sheets
    If ssheet.Name <> "hello" Then
        ssheet.Delete
    End If
Next

'工作簿操作
' 打开已经存在的文件
Workbooks.Open ("C:\Users\wyh\Desktop\AIYI\hadoop\vbaDemo\001.xls") ' 打开工作簿
ActiveWorkbook.Sheets(1).Range("a1") = "hello world!"                ' 对激活工作簿的表1进行操作
ActiveWorkbook.Save                                                 ' 保存
ActiveWorkbook.Close                                                ' 关闭

' 新建工作簿
Workbooks.Add
ActiveWorkbook.Sheets(1).Range("a1") = "hello world!"                ' 对激活工作簿的表1进行操作
ActiveWorkbook.SaveAs Filename:="C:\Users\wyh\Desktop\AIYI\hadoop\vbaDemo\002.xls"
ActiveWorkbook.Close                                                ' 关闭


'将一个工作簿里的多个sheet另存为

For Each ssheet In Sheets
    ssheet.Copy
    ActiveWorkbook.SaveAs Filename:="C:\Users\wyh\Desktop\AIYI\hadoop\vbaDemo\" & ssheet.Name
    ActiveWorkbook.Close
Next


Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

8.处理每个sheet的逻辑

Sub opeateWorkBook()
Dim ssheet As Worksheet
Dim rng As Range
Dim i, j As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False


' 循环处理每个sheet
For Each ssheet In Sheets
    i = i + 1
    MsgBox "sheet" & i
    ssheet.Select
    
    ' 循环处理每个单元格
    For Each rng In Range("a1:a10")
        j = j + 1
        Range("a" & j) = j
    
        MsgBox "单元格" & j
    
    Next

Next


Application.ScreenUpdating = False
Application.DisplayAlerts = False



End Sub

9.循环将数据拷贝到对应的sheet

Sub rangeLearning()

' 定义变量
Dim i, j, m, n As Integer

' 定义sheet个数
Dim cnt As Integer
cnt = Sheets.Count

MsgBox "工作簿有" & cnt & "个sheet"

For i = 2 To cnt

    ' 定义sheet1数据行数
    
    Dim row_cnt As Integer
    row_cnt = range("a65536").End(xlUp).Row
    MsgBox "sheet1有" & row_cnt & "行数据"
    
    ' 循环判断所有数据行
    For j = 2 To row_cnt
    
        ' 判断数据该拷贝到哪个sheet内
        If Sheet1.range("d" & j) = Sheets(i).Name Then
        
            ' 将数据拷贝到对应sheet
            m = Sheets(i).range("a65536").End(xlUp).Row
            Sheet1.range("d" & j).EntireRow.Copy Sheets(i).range("a" & m + 1)
        End If
        
    Next
Next



End Sub

10.拆分表个并拷贝数据

Sub createNewSheet()
Dim sht As Worksheet
Dim k As Integer
Dim cnt As Integer
Dim col As Integer
Dim sht0 As Worksheet




col = InputBox("请输入按第几列拆分表", "拆-----分-----表")
Set sht0 = ActiveSheet

' 清理已经拆分出来的表
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If Sheets.Count > 1 Then
    
    Dim ssheet As Worksheet
    
    For Each ssheet In Sheets
    
        If ssheet.Name <> sht0.Name Then
            ssheet.Delete
        End If
    
    Next

End If
Application.DisplayAlerts = True

cnt = sht0.Range("a65536").End(xlUp).Row ' 数据行数

' 拆分表
For i = 2 To cnt
    k = 0
    For Each sht In Sheets
        ' 判断表是否存在,并做标记
        If sht.Name = sht0.Cells(i, col) Then
            k = 1
        End If
    Next
    
    If k = 0 Then
        ' 新建表
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sht0.Cells(i, col)
    End If
    
    
Next

' 拷贝数据
For j = 2 To Sheets.Count
    'field 代表根据第几列筛选,Criteria1筛选条件
   sht0.Range("a1:z" & cnt).AutoFilter field:=col, Criteria1:=Sheets(j).Name
   sht0.Range("a1:z" & cnt).Copy Sheets(j).Range("a1")
    
Next

sht0.Range("a1:z" & cnt).AutoFilter

sht0.Select

MsgBox "拆分表已经完成(☆_☆)人丑就要多读书"
        
        


End Sub

12.获取使用的表格行数,列数

Sub mysub()
	' 使用的列数
	
    LastCol = ActiveSheet.UsedRange.Columns.Count
    Sheet1.UsedRange.Columns.Count

    ' 使用的行数
    LastRow = ActiveSheet.UsedRange.Rows.Count
    Sheet1.UsedRange.Rows.Count

End Sub

13.选中的单元整行颜色自动加重

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

' 选中的单元整行颜色加重
Cells.Interior.Pattern = xlNone
Selection.EntireRow.Interior.Color = 65535

End Sub

14.自动筛选

Private Sub Worksheet_Change(ByVal Target As Range)
' 自动筛选

' 操作时关闭事件
Application.EnableEvents = False

' 拷贝数据前清空位置
Range("l1:q63356").ClearContents

' 筛选指定数据
Range("a1:f100").AutoFilter field:=3, Criteria1:=Range("i2").Value

' 将筛选出的数据拷贝到指定位置

Range("a1:f100").Copy Range("l1")
Range("a1:f100").AutoFilter

Application.EnableEvents = True


End Sub

15.自动刷新表

Private Sub Worksheet_Activate()

' 自动刷新工作表
ActiveWorkbook.RefreshAll

End Sub

16.格式设置语句

Sub mysub()

' 格式设置语句
    With Sheet1
        .Range("a1").Font.Size = 18
        .Range("a1").Font.Color = 45536
    
    End With
    
End Sub

17.自动备份表格

Private Sub Workbook_Open()
' 声明变量
Dim WshShell As Object
Dim desktop  As String
Dim path As String

'创建shell对象
Set WshShell = CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")

path = ThisWorkbook.Path

ThisWorkbook.SaveCopyAs desktop & "\" & Format(Now(), "yyyymmddhhmmss") & ".xlsm"
ThisWorkbook.SaveCopyAs path& "\" & Format(Now(), "yyyymmddhhmmss") & ".xlsm"

End Sub

18.合并工作簿

Sub dirDemo()
Dim i As Integer
Dim str As String
Dim wb As Workbook
Dim sht As Worksheet


' 获取文件夹内的excel文件

str = dir("C:\Users\wyh\Desktop\wyh_files\*.xls*")

For i = 1 To 10 Step 1

    
    ' 打开文件夹内的工作簿

    Set wb = Workbooks.Open("C:\Users\wyh\Desktop\wyh_files\" & str)
    
    ' 循环每个工作簿
    
    For Each sht In wb.Sheets
    
        ' 复制每个sheet
        
        sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name
    
    
    Next
    
    
    wb.Close
    
    
    str = dir()
    
    If str = "" Then
        Exit For
        
    End If


Next


End Sub

19.计时器

Sub timerSub()
t = timer

' 中间工程代码


 t = timer - t
 
 MsgBox "程序运行了" & t & "秒!"

End Sub

20.数组应用(计算速度快)

Sub arrDemo()
Dim i, col As Long

' 定义数组
Dim arr()

row_cnt = Range("a65536").End(xlUp).Row - 1

ReDim arr(1 To row_cnt)
    
' 将计算结果放入数组
For i = 1 To row_cnt
    arr(i) = Range("b" & i + 1) * Range("c" & i + 1)
Next

' 取出数组里的最大值
Range("h3") = Application.WorksheetFunction.Max(arr)

' 匹配最大值所对应的行
Range("h2") = Range("a" & Application.WorksheetFunction.Match(Range("h3"), arr, 0) + 1)


' 获取数组最大和最小边界
MsgBox "数组下边界" & LBound(arr)
MsgBox "数组上边界" & UBound(arr)

End Sub

21.textbox和listbox控件应用

Private Sub ListBox1_Click()
    Me.TextBox1.Value = Me.ListBox1.Value
    Me.ListBox1.Visible = False
End Sub

Private Sub TextBox1_Change()
If Len(Me.TextBox1.Value) > 4 Then
    Me.ListBox1.Clear
    For i = 2 To 10
        If InStr(Sheet1.Range("i" & i), Me.TextBox1.Value) > 0 Then
            Me.ListBox1.AddItem Sheet1.Range("i" & i)
        End If
    Next
    If Me.ListBox1.ListCount > 0 Then
        Me.ListBox1.Visible = True
    Else
         Me.ListBox1.Visible = False
    End If
    
Else

    Me.ListBox1.Visible = False
    
End If
    
    
End Sub

22.打开多文件

Sub open_excel_files()
Dim arr()
Dim i As Integer
Dim wb, wb1 As Workbook
Dim sht As Worksheet

On Error Resume Next
Set wb1 = ActiveWorkbook
' Set wb1 = ActiveWorkbook
Set sht1 = ActiveSheet

On Error Resume Next
' 打开多文件的数组
arr = Application.GetOpenFilename("Excel数据文件,*.xls*", , , , True)
     ' 循环打开文件并处理
    For i = LBound(arr) To UBound(arr)
        
        Set wb = Workbooks.Open(arr(i))
        ' 合并选中的文件
        For Each sht In wb.Sheets
            sht.Copy after:=wb1.Sheets(wb1.Sheets.Count)
            wb1.Sheets(wb1.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name
        Next
        wb.Close
    Next


End Sub

23.使用ADO操作外部数据

Sub test()
' 使用前请确认是否勾选了Microsoft ActiveX Data Object  x.x  Library！！！
Dim conn As New ADODB.Connection
Dim sql As String
' 注意这个链接文件的路径！！！需要把edata文件放入d:\data文件夹！！

Range("a2:z1000").ClearContents
conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=D:\data\Edata.xlsx;extended properties=""excel 12.0;HDR=YES"""

sql = "select a.姓名,年龄,性别,月薪 from (select * from [data$] union all select * from [data2$])a left join [data3$] on a.姓名=[data3$].姓名"

Range("a2").CopyFromRecordset conn.Execute(sql)

conn.Close
End Sub

Excel文件

Dim conn As New ADODB.Connection
conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=D:\data\Edata.xlsx;extended properties=""excel 12.0;HDR=YES"""
conn.Close

ACCESS文件
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\data\Adata.accdb"

Mysql数据库
conn.Open  "Provider=SQLOLEDB;DataSource=" & Path & ";Initial Catolog=" & strDataName


MSSQL数据库
conn.Open  "Provider=MSDASQL;Driver={SQL Server};Server=" & Path & ";Database=" & strDataName

Oracle数据库
conn.Open  "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password"

24.按位置插入并调整图片

Sub test()
On Error Resume Next
Dim shp, shp1 As Shape

For Each shp1 In Sheet1.Shapes
    shp1.Delete
Next

For i = 2 To 12
Set shp = Sheet1.Shapes.AddPicture("d:\data\" & Range("a" & i) & ".jpg", msoFalse, msoCTrue, Range("d" & i).Left, Range("d" & i).Top, Range("d" & i).Width, Range("d" & i).Height)
shp.Placement = xlMoveAndSize
Next

End Sub

25.改文件名

Sub test()
Dim i As Integer

On Error Resume Next

For i = 2 To 12
Name "d:\data\" & Range("a" & i) & ".jpg" As "d:\data\" & Range("a" & i) & Range("d" & i) & ".jpg"
Next


End Sub

26.类方法与属性举例

' 类方法

Sub Sdelete(str As String)
Dim sht As Worksheet
    For Each sht In Sheets
        If sht.Name = str Then
            Application.DisplayAlerts = False
            sht.Delete
            Application.DisplayAlerts = True
        End If
    Next
End Sub


Sub Sadd(str As String)
Dim sht, sht1 As Worksheet
    For Each sht In Sheets
        If sht.Name = str Then
            k = k + 1
        End If
    Next
    
    If k = 0 Then
        Set sht1 = Sheets.Add
        sht1.Name = str
    End If

End Sub


Sub Add()

Sheets.Add after:=Sheets(Sheets.Count)



End Sub

' 类属性
Property Get Scount()

Scount = Sheets.Count
End Property

27.销售系统练习

Dim arr()
Dim ID As String
Dim DJ As Long



Private Sub CommandButton1_Click()



If Me.ListBox1.Value <> "" And Me.ListBox2.Value <> "" And Me.ListBox3.Value <> "" And Me.TextBox1 > 0 Then
Me.ListBox4.AddItem
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 0) = ID
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 1) = Me.ListBox1.Value
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 2) = Me.ListBox2.Value
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 3) = Me.ListBox3.Value
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 4) = Me.TextBox1.Value
Me.ListBox4.List(Me.ListBox4.ListCount - 1, 5) = Me.TextBox1.Value * Me.Label2.Caption
Else

MsgBox "请正确选择商品"
End If


End Sub

Private Sub ListBox1_Click()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")

For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value Then
        dic(arr(i, 3)) = 1
    End If
Next

Me.ListBox2.List = dic.keys
Me.ListBox3.Clear
Me.Label2.Caption = 0

End Sub

Private Sub ListBox2_Click()

Dim dic
Set dic = CreateObject("Scripting.Dictionary")

For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value Then
        dic(arr(i, 4)) = 1
    End If
Next

Me.ListBox3.List = dic.keys
Me.Label2.Caption = 0


End Sub

Private Sub ListBox3_Click()

For i = LBound(arr) To UBound(arr)

    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value And arr(i, 4) = Me.ListBox3.Value Then
        ID = arr(i, 1)
        DJ = arr(i, 5)
    End If
Next

Me.Label2.Caption = DJ


End Sub

Private Sub UserForm_Activate()
Dim dic
arr = Sheet1.Range("a2:e" & Sheet1.Range("a65536").End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")

For i = LBound(arr) To UBound(arr)
    dic(arr(i, 2)) = 1
Next
Me.ListBox1.List = dic.keys
End Sub

28 转换文本编码格式

Sub WriteANSItoUTF8withoutBOM(strFile As String)
Set UTFStream = CreateObject("ADODB.Stream")
Set ANSIStream = CreateObject("ADODB.Stream")
Set BinaryStream = CreateObject("ADODB.Stream")



'ANSI
ANSIStream.Type = 2 'adTypeText
ANSIStream.Mode = 3 'adModeReadWrite
ANSIStream.Charset = "GB2312"
ANSIStream.Open
ANSIStream.LoadFromFile strFile


' UTFStream
UTFStream.Type = 2 'adTypeText
UTFStream.Mode = 3 'adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
ANSIStream.CopyTo UTFStream

' BinaryStream
UTFStream.Position = 3 'skip BOM
BinaryStream.Type = 1 'adTypeTexts
BinaryStream.Mode = 3 'adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream

'Strips BOM(first 3 bytes)
BinaryStream.SaveToFile strFile, 2
BinaryStream.Flush
BinaryStream.Close

End Sub

Sub createFile()

    ' 声明变量
    Dim WshShell As Object
    Dim desktop  As String
    Dim fileName As String
    Dim file_path As String
    
    
    On Error GoTo baseError
    
    '创建shell对象
    Set WshShell = CreateObject("WScript.Shell")
    desktop = WshShell.SpecialFolders("Desktop")
    
    ' 用户自定义文件目录ming
    
    FolderName = InputBox("桌面创建文件夹", "目录名称:")
    
    
    ' 创建文件夹之前先删除文件夹
    If Dir(desktop & "\" & FolderName, vbDirectory) <> "" Then
    
       
       Set fso = CreateObject("Scripting.FileSystemObject")
       Set folderObj = fso.getfolder(desktop & "\" & FolderName)
       folderObj.Delete
       
    End If
    
    
    MkDir desktop & "\" & FolderName
    
    
    
    
    
    '定义新建的文本存放路径和文本名
    fileName = "runJob.sh"
    file_path = desktop & "\" & FolderName & "\" & fileName
    
    
    ' 以读写方式打开文件，每次写内容都会覆盖原先的内容
    Open file_path For Output As #1
    
    ' 一行一行往文本里写入数据
    Print #1, "#!/bin/bash"
    Print #1, "echo 'hello world!!!'"
    Print #1, "echo 'hello world!!!'"
    Print #1, "echo 'hello world!!!'"
    Close #1 '关闭文本
    
    
    Call WriteANSItoUTF8withoutBOM(file_path)
    
baseError:
     On Error GoTo 0

End Sub