VBA代码碎片
- 1.**获取用户桌面路径**
- 2.**判断文件或文件夹是否存在**
- 3.**创建目录,删除目录,切换目录**
- 4.**删除行一般从下往上删(避免漏处理)**
- 5.**新建文本并写入数据**
- 6.**获取激活工作表名字**
- 7.**工作簿操作(打开,新建,另存为)**
- 8.**处理每个sheet的逻辑**
- 9.**循环将数据拷贝到对应的sheet**
- 10.**拆分表个并拷贝数据**
- 12.**获取使用的表格行数,列数**
- 13.**选中的单元整行颜色自动加重**
- 14.**自动筛选**
- 15.**自动刷新表**
- 16.**格式设置语句**
- 17.**自动备份表格**
- 18.合并工作簿
- 19.计时器
- 20.数组应用(计算速度快)
- 21.**textbox和listbox控件应用**
- 22.**打开多文件**
- 23.**使用ADO操作外部数据**
- 25.**改文件名**
- 26.**类方法与属性举例**
- 27.**销售系统练习**
- 28 转换文本编码格式
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