VBA 专辑 之三
本帖最后由 wp231957 于 2023-1-13 14:40 编辑专辑一戳这里
专辑二戳这里
专辑四 请戳这里前进
打开文件对话框，可以多选文件
Sub wp()
Application.DisplayAlerts = False '退出excel 不抛出提示框,当然改动也不会存盘
Application.ScreenUpdating = False '关闭屏幕更新
Dim f
f = Application.GetOpenFilename("EXCEL文档,*.xls,EXCEL文档,*.xlsx", 2, MultiSelect:=True)
Dim wb As Workbook
For x = 1 To UBound(f)
Set wb = Workbooks.Open(f(x)) '打开外部工作簿
Windows(wb.Name).Activate
arr = Sheets(1).Range("c1:c12")
Windows(ThisWorkbook.Name).Activate
col = Cells(1, 256).End(xlToLeft).Column
Cells(1, col + 1).Resize(UBound(arr, 1)) = arr
wb.Close
Next
'Stop
End Sub
本帖最后由 wp231957 于 2020-5-31 19:29 编辑
在sheets 的末尾 插入sheet
Sub wp()
'Debug.Print Sheets.Count
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Format(Now(), "yyyymmdd")
End Sub
如何判断一个sheet是否是空表
Sub wp2()
For Each x In Sheets
If IsEmpty(x.UsedRange) Then
Debug.Print x.Name & "是一个空表"
Else
Debug.Print x.Name & "表存在数据"
End If
Next
End Sub
一个函数，判断某个工作簿当前是否打开状态
Function isworkbookopen(bookname As String) As Boolean
On Error Resume Next
Dim wkb As Object
Set wkb = Workbooks(bookname) '如果工作簿没有打开，则会引发错误处理
If Err.Number = 0 Then
isworkbookopen = True
Else
isworkbookopen = False
End If
End Function
测试案例：（实测通过）
If isworkbookopen("123.xlsx") Then
Debug.Print "open"
Else
Debug.Print "需要打开"
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "123.xlsx") '打开外部工作簿
End If 本帖最后由 wp231957 于 2020-6-2 14:58 编辑
select where ... in .....子句中拼接字符串的示例
拼接演示：
: Sql : "select* from [人员信息$a1:d15] where 姓名 in ('张三','李四')" : Variant/String
Sub wp()
arr = Split(Application.Trim(Range("a2").Value), " ")
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select* from [人员信息$a1:d15] where 姓名 in ('" & Join(arr, "','") & "')"
Sheets("查询").Range("a7:d1000").Clear
Sheets("查询").Range("a7").CopyFromRecordset Cnn.Execute(Sql)
End Sub
在所有sheet的D列之前插入新列，原D列 变更为E列
Sub wp2()
For Each x In Sheets
x.Columns("D").EntireColumn.Insert
Next
End Sub
字典的应用之挑选两列数据的重合部分 和非重合部分
Sub wp()
Set da = CreateObject("scripting.dictionary")
Set Db = CreateObject("scripting.dictionary")
arr = Range("a1:a17")
brr = Range("b1:b17")
For i = 1 To UBound(arr) '创建字典（初始化字典）
da(arr(i, 1)) = ""
Db(brr(i, 1)) = ""
Next
k = 1
l = 1
m = 1
For i = 1 To UBound(arr)
If da.exists(brr(i, 1)) Then '扫描Brr数组中 与字典A 中一致的数据
Cells(k, 4) = brr(i, 1)
k = k + 1
Else
Cells(l, 5) = brr(i, 1) 'Brr数组中 有，但是字典A 中没有的数据
l = l + 1
End If
If Not Db.exists(arr(i, 1)) Then 'Arr数组中 有，但是字典B 中没有的数据
Cells(m, 6) = arr(i, 1)
m = m + 1
End If
Next
End Sub
把所有工作簿的表(仅包含一个工作表） 都复制到一个工作簿中，表名与原工作簿同名
Sub wp()
Application.DisplayAlerts = False '退出excel 不抛出提示框,当然改动也不会存盘
Application.ScreenUpdating = False '禁止刷屏
Dim f
f = Application.GetOpenFilename("EXCEL文档,*.xls,EXCEL文档,*.xlsx", 1, MultiSelect:=True)
Dim wb As Workbook
For x = 1 To UBound(f)
Set wb = Workbooks.Open(f(x)) '打开外部工作簿
Windows(wb.Name).Activate
Sheets(1).Select
Sheets(1).Name = Left(wb.Name, Len(wb.Name) - 4) '去除.XLS
Sheets(1).Copy after:=ThisWorkbook.Sheets(1)
wb.Close
Next
End Sub
区域数据拷贝
Sub wp()
Application.DisplayAlerts = False
Dim wb As Workbook
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "数据.xlsx") '打开外部工作簿
Windows("数据.xlsx").Activate
Sheets(1).Activate
arr = Range("a2:d" & Range("A65536").End(xlUp).Row)
Windows(ThisWorkbook.Name).Activate
Sheets(1).Activate
Range("a2").Resize(UBound(arr, 1), 4) = arr
wb.Close
End Sub
字符串分割以及INSTR用法一例
Sub wp()
s = "AAA_MM_gg-77-99_BB_sdfds"
If InStr(s, "AAA") Then
Debug.Print "合格的字符串"
arr = Split(s, "_")
For x = 1 To UBound(arr)
If InStr(arr(x), "-") Then
Debug.Print arr(x)
End If
Next
Else
Debug.Print "字符串非法"
End If
End Sub
字典应用之 按字体颜色累加目标单元格数值
Sub wp()
arr = Range("c5:f13").Select
Set da = CreateObject("scripting.dictionary")
For Each x In Selection '创建并初始化字典，也就是统计一下目标单元格区域中，包含几种颜色
If x(1) <> "" Then
da(x.Interior.ColorIndex) = 0 '初始化，因为要参与计算所以不能赋值为空
End If
Next
For Each x In da.keys '为每一种颜色 进行累加值
For Each a In Selection
If a.Interior.ColorIndex = x Then
da(x) = da(x) + a '累加
End If
Next
Next
For Each x In da.keys
Debug.Print x & ":=" & da(x) '输出
Next
End Sub
按行输出二维数组
Sub wp()
Sheets("wp").Activate
arr = Range("A2:k6")
For x = 1 To 5
For I = LBound(arr, 2) To UBound(arr, 2)
Debug.Print arr(x, I);
Next
Debug.Print
Next
End Sub
本帖最后由 wp231957 于 2020-6-15 08:55 编辑
sqlwhere 子句 后面跟 range 的语法示例
单元格的清空
Sub wp()
arr = Split(Application.Trim(Range("a2").Value), " ")
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select 日期,营业额 from where 姓名 =""" & Range("e1") & """"
Sheets("sheet2").Range(Cells(2, 5), Cells(Rows.Count, 6)).Clear
Sheets("sheet2").Range("e2").CopyFromRecordset Cnn.Execute(Sql)
End Sub
单元格区域清空的两种方法
range("a2:c65536").delete shift:=xlup
Sheets("sheet2").Range(Cells(2, 5), Cells(Rows.Count, 6)).Clear
本帖最后由 wp231957 于 2020-6-17 09:31 编辑
一维数组，二维数组 给range 赋值 时 用法
转置有行数限制 ，推荐使用二维数组，二维数组我测试100万行数据 无错误
'二维数组 可以直接赋值
Sub wp2()
Const M As Long = 100000
Dim arr(1 To M, 1 To 1)
For i = 1 To M
arr(i, 1) = i
Next
Sheets("sheet3").Range("a1:a" & M) = arr
End Sub
'一维数组需要转置 才可以赋值给range
Sub wp3()
Const M As Long = 100000
Dim arr(1 To M)
For i = 1 To M
arr(i) = i
Next
Sheets("sheet3").Range("a1:a" & M).Resize(M, 1) = Application.Transpose(arr)
End Sub
sql 语句测试 100万行 可以通过获取记录行数
Sub wp4()
Set Cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("adodb.recordset")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select * from "
rst.cursorlocation = 3
rst.Open Sql, Cnn
Debug.Print rst.RecordCount '返回记录数
Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
End Sub
vbaformat 日期函数 一例
"yyyy/m/d"这里用一个m 一个 d来匹配 单个的月 日， 如果用MMDD则会出现前导0 的情况，视需求而选择
Sub 按钮1_Click()
arr = Range("a2:c6")
Dim brr(1 To 5, 1 To 1)
For x = 1 To UBound(arr)
brr(x, 1) = arr(x, 1) & Format(arr(x, 3), "yyyy/m/d")
Next
Range("d2").Resize(5) = brr
End Sub
解决日期显示的是一个整形数值得问题
Sub wp4()
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select distinct 日期,员工姓名 ,count(员工姓名) from group by 日期,员工姓名"
Columns("D:D").NumberFormatLocal = "yyyy/m/d"
Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
End Sub
Sheet1.UsedRange.Rows.Autofit '使用范围内的行自动匹配行高
Sheet1.UsedRange.Columns.Autofit'使用范围内的列自动匹配列宽
Sub wp()
arr = Array("商品编号", "商品单价", "销售数量", "销售金额")
Sheets("sheet1").Range("h1").Resize(1, 4) = arr '横向填充
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
sql = "select 商品编号,商品单价,count(*) as 销售数量from group by 日期,商品编号,商品单价"
sql = "select 商品编号,商品单价,销售数量,商品单价*销售数量from (" & sql & ") "
Sheets("sheet1").Range("h2").CopyFromRecordset cnn.Execute(sql)
End Sub
神操作，单元格部分文本颜色的改变
Sub wp()
Range("d8").Value = "test text"
Range("d8").Characters(2, 4).Font.ColorIndex = 3
Cells(9, "d").Value = "我爱中国"
Cells(9, "d").Characters(2, 4).Font.Color = vbRed
End Sub 双表联动更新 示例
Sub wp()
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
sql2 = "update [" & Sheets("主页").Range("A1") & "$] a inner join [主页$b2:d7] b on a.身份证号码=b.身份证号码 set a.身份证号码=b.更正编码"
Debug.Print sql2
Cnn.Execute (sql2)
Cnn.Close
End Sub
页:
[1]
2