VBA 专辑之一
本帖最后由 wp231957 于 2023-1-13 14:39 编辑专辑三 戳这里
专辑二 戳这里
专辑四 请戳这里前进
1、获取倒数第二行的行号：
Function get_row()
get_row = Range("A65536").End(xlUp).Offset(-1, 0).Row
End Function
Sub test()
Row = get_row
MsgBox Row
End Sub
Range("A65536").End(xlUp).Row+1 '获取第一个无数据行
Cells(行号, 256).End(xlToLeft).Column ' 获取第一个无数据列
brr = Range("a1:a" & Range("A" & Rows.Count).End(xlUp).Row)
2、使用变量 获取range区域
Range("m3:" & "p" & Row).Select
3、删除空行，如果有连续空行，会出现一些问题，所以从下往上删除
Sub test2()
Row = get_row
Range("b3:" & "b" & Row).Select
row2 = Selection.Rows.Count
For i = row2 + 2 To 1 + 2 Step -1
If (Cells(i, 2) = "") Then
Rows(i).Delete
End If
Next
End Sub
4、校验原始表中是否包含合并单元格
Sub pd()
Row = get_row
Range("b3:" & "t" & Row).Select
For Each cc In Selection
If cc.MergeCells = True Then
MsgBox "表中包含合并单元格，无法进行排序"
End
End If
Next
End Sub
5、获取某行最右侧包含数据的列
Sub test()
MsgBox Cells(125, 256).End(1).Column '获取125行的最右侧包含数据的列，返回的是一个数值（例如：9 表示I列）
End Sub
6、检索某列重复值（去重）使用了数据库以及CopyFromRecordset方法
Sub wp()
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 distinct * from "
Sheets("sheet2").Range("h" & 2).CopyFromRecordset Cnn.Execute(Sql)
End Sub
自动填充数列
Sub wp()
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 distinct * from "
Sheets("sheet2").Range("a1:aa20000").Clear
Sheets("sheet2").Range("a" & 1).CopyFromRecordset Cnn.Execute(Sql)
Sheets("sheet2").Range("A1") = 100001
Sheets("sheet2").Range("A2") = 100002
Sheets("sheet2").Range("A1:A2").Select
Selection.AutoFill Destination:=Sheets("sheet2").Range("A1:A1000"), Type:=xlFillDefault
End Sub
多个相同结构表的拼接，插入表头，记录之间密切结合
Sub wp()
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.Path & "\" & "对账单A.xlsx"
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("mm").Activate
'插入header
Set rs = cnn.Execute(Sql)
For i = 1 To rs.Fields.Count
Cells(1, i) = rs.Fields(i - 1).Name
Next i
rs.Close
Sheets("mm").Range("a2").CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("rx").Activate
'插入header
Set rs = cnn.Execute(Sql)
For i = 1 To rs.Fields.Count
Cells(1, i) = rs.Fields(i - 1).Name
Next i
rs.Close
Sheets("rx").Range("a2").CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from [加工单$]"
Windows(ThisWorkbook.Name).Activate
Sheets("加工单").Activate
'插入header
Set rs = cnn.Execute(Sql)
For i = 1 To rs.Fields.Count
Cells(1, i) = rs.Fields(i - 1).Name
Next i
rs.Close
Sheets("加工单").Range("a2").CopyFromRecordset cnn.Execute(Sql)
row1 = Sheets("mm").Range("A65536").End(xlUp).Row + 1
row2 = Sheets("rx").Range("A65536").End(xlUp).Row + 1
row3 = Sheets("加工单").Range("A65536").End(xlUp).Row + 1
cnn.Close
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\" & "对账单B.xlsx"
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("mm").Range("a" & row1).CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("rx").Range("a" & row2).CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from [加工单$]"
Windows(ThisWorkbook.Name).Activate
Sheets("加工单").Range("a" & row3).CopyFromRecordset cnn.Execute(Sql)
row1 = Sheets("mm").Range("A65536").End(xlUp).Row + 1
row2 = Sheets("rx").Range("A65536").End(xlUp).Row + 1
row3 = Sheets("加工单").Range("A65536").End(xlUp).Row + 1
cnn.Close
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\" & "对账单C.xlsx"
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("mm").Range("a" & row1).CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from "
Windows(ThisWorkbook.Name).Activate
Sheets("rx").Range("a" & row2).CopyFromRecordset cnn.Execute(Sql)
Sql = "select* from [加工单$]"
Windows(ThisWorkbook.Name).Activate
Sheets("加工单").Range("a" & row3).CopyFromRecordset cnn.Execute(Sql)
cnn.Close
End Sub
关于列合并相加计算的sql语法一则
Sub wp()
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select 编码,[名称/规格/型号],sum(数量) from [记录簿$] group by 编码,[名称/规格/型号]"
Sheets("sheet1").Range("a2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
End Sub
Sub wp2()
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "select 货号,[名称/型号/规格],订单DD01+订单DD02+订单DD03+订单DD04+订单DD05+订单DD06+订单DD07+订单DD08+订单DD09 as 订单 from [货物表$] "
Sheets("sheet1").Range("f2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
End Sub
7、关于listboxtextboxsplitubound 的部分用法
Private Sub CommandButton1_Click()
x = ListBox1.Text
ListBox1.RemoveItem (ListBox1.ListIndex) '删除列表选中项
TextBox1.Text = x
End Sub
Private Sub UserForm_Initialize()
s = Range("c1").Value
arr = Split(s, Chr(10))'按换行符 拆分
For i = 1 To UBound(arr) 'ubound 探测数组长度
ListBox1.AddItem arr(i)
Next
End Sub
Sub wp()
arr = Range("c2:c11")
For x = 1 To UBound(arr)
tmp = Split(arr(x, 1), " ") ' tmp = Split(Application.Trim(arr(x, 1)), " ")可以解决多个空格的问题
If UBound(tmp) > 0 Then
s = ""
t = ""
For Z = 0 To UBound(tmp)
If InStr(s, Split(tmp(Z), "/")(1)) = 0 Then
s = s + Split(tmp(Z), "/")(1) + " "
End If
If InStr(t, Split(tmp(Z), "/")(0)) = 0 Then
t = t + Split(tmp(Z), "/")(0) + " "
End If
Next
Range("e" & x + 1) = s
Range("f" & x + 1) = t
Else
Range("e" & x + 1) = Split(arr(x, 1), "/")(1)
Range("f" & x + 1) = Split(arr(x, 1), "/")(0)
End If
Next
End Sub
8、创建一个长度为0的文本文件
Sub wp()
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFilePath = Excel.ThisWorkbook.Path & "\" & "1" & ".txt"
With oFSO
Set oTextStream = oFSO.CreateTextFile(sFilePath, False)
End With
End Sub
全选复制？ 永恒的蓝色梦想 发表于 2020-5-19 09:28
全选复制？
嗯，最后恢复时，剪贴板是空的 ，白忙乎了 本帖最后由 wp231957 于 2020-6-10 10:59 编辑
vba sql左右连接测试代码
Sub wp()
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
'左连接测试
Sql = "select a.A列,b.C列 from a left join . b on a.A列=b.C列"
Sheets(1).Range("h2").CopyFromRecordset cnn.Execute(Sql)
'右连接测试
Sql = "select a.A列,b.C列 from a right join . b on a.A列=b.C列"
Sheets(1).Range("k2").CopyFromRecordset cnn.Execute(Sql)
'根据左连接取两列相同
Sql = "select b.C列 from a left join . b on a.A列=b.C列"
Sheets(1).Range("m2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
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
'左连接测试
Sql = "select a.A列,b.C列 from a left join . b on a.A列=b.C列"
Sheets(1).Range("h2").CopyFromRecordset cnn.Execute(Sql)
'右连接测试
Sql = "select a.A列,b.C列 from a right join . b on a.A列=b.C列"
Sheets(1).Range("k2").CopyFromRecordset cnn.Execute(Sql)
'根据左连接取A列中包含，但是c列中没有的数据
Range("h1") = "A列"
Range("i1") = "C列"
Sql = "select A列 from where C列 is null"
'Debug.Print Sql
Sheets(1).Range("m2").CopyFromRecordset cnn.Execute(Sql)
'根据右连接取C列中包含，但是A列中没有的数据
Range("k1") = "A列"
Range("l1") = "C列"
Sql = "select c列 from where A列 is null"
Sheets(1).Range("n2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
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
'根据左连接 获取A列中包含，C列中没有的数据
Sql = "select a.A列,b.C列 from a left join . b on a.A列=b.C列"
sql2 = "select a.A列 from (" & Sql & ") where b.C列 is null"
Sheets(1).Range("m2").CopyFromRecordset cnn.Execute(sql2)
'根据右连接 获取C列中包含，A列中没有的数据
Sql = "select a.A列,b.C列 from a right join . b on a.A列=b.C列"
sql2 = "select b.C列 from (" & Sql & ") where a.A列 is null"
Sheets(1).Range("n2").CopyFromRecordset cnn.Execute(sql2)
'根据左连接 获取A列C列中共有的数据
Sql = "select b.C列 from a left join . b on a.A列=b.C列"
Sheets(1).Range("l2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
End Sub
本帖最后由 wp231957 于 2020-6-11 15:56 编辑
利用二维数组自动填充列
Sub ttt()
Dim ii, arr(1 To 1000000, 1 To 1)
For ii = 1 To 1000000 Step 1
arr(ii, 1) = ii
Next ii
Range("A1").Resize(UBound(arr, 1), 1) = arr
End Sub
获取单元格数据格式，是输入数据还是计算公式
MsgBox Range("c2").Formula sql应用之插入记录
Sub wp()
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "insert into [芯盒制芯数量监控$] select 模具号,芯盒架位,sum(计划数量) as 清洗前数量累计 from [制芯计划$] group by 模具号,芯盒架位"
Cnn.Execute Sql
Sql = "select 模具号,芯盒架位,sum(清洗前数量累计)from [芯盒制芯数量监控$] group by 模具号,芯盒架位"
Sheets("芯盒制芯数量监控").Range("a2").CopyFromRecordset Cnn.Execute(Sql)
Cnn.Close
End Sub
测试左连接中使用right 分割字段的用法演示
Sub wp()
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\货单A.xlsx"
Sql = "select a.名称 ,right(b.编码,10) as bm ,a.重量 ,a.编号, b.库号 ,b.库位码 from a left join . b on a.编码=int(right(b.编码,10))"
Sheets(1).Range("a15").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
End Sub
RANGE里还有这个操作 RANGE.FIND直接查找数据
Sub 查找()
Set c = Sheets("数据").Range("f4:f31").Find(Sheets(2).Range("f1").Value)
If Not c Is Nothing Then
MsgBox c.Address
End If
End Sub
Private Sub CommandButton2_Click()
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库.mdb"
Sql2 = "update 数据set 姓名='" & ComboBox2.Value & "' where 号码 between " & TextBox1.Text & "and " & TextBox2.Text
cnn.Execute (Sql2)
cnn.Close
End Sub 66666666666 复制带有超级链接的单元格
Sub wp()
Sheets(1).Range("g5").Copy
Sheets(2).Activate
Sheets(2).Range("g7").Select
ActiveSheet.Paste
End Sub
wp231957 发表于 2020-7-6 09:54
复制带有超级链接的单元格
Sub wp()
设置单元格格式以及如何复制range里面的一行数据到新的行
Sub wp()
arr = Range("a2:d479")
brr = Range("f2:f6")
'设置选择区域为文本格式
Range("j:j").Select
Selection.NumberFormatLocal = "@"
xh = 8
For x = 1 To UBound(arr)
For y = 1 To UBound(brr)
If arr(x, 1) = brr(y, 1) Then
Cells(xh, 10).Resize(1, 4) = Application.Index(arr, x, 0) '单独复制一行数据到新的行
xh = xh + 1
End If
Next
Next
End Sub
wp231957 发表于 2022-10-27 10:35
设置单元格格式以及如何复制range里面的一行数据到新的行
提取单元格中字体颜色为默认（自动）的 示例其他颜色略过
Sub wp2()
For i = 1 To 8
lstr = ""
For j = 1 To Len(Range("d" & i))
If Range("d" & i).Characters(Start:=j, Length:=1).Font.ColorIndex = xlAutomatic Then
lstr = lstr & Mid(Range("d" & i).Value, j, 1)
End If
Next
Debug.Print lstr
Next
End Sub wp231957 发表于 2022-10-31 10:31
提取单元格中字体颜色为默认（自动）的 示例其他颜色略过
把两个不同的格式的单元格的内容连接再一起，格式不变
Sub wp()
Dim f7 As Range
Dim h7 As Range
Set f7 = Range("f7")
Set h7 = Range("h7")
Dim k10 As Range
Set k10 = Range("k10")
k10.Value = f7.Value & h7.Value
With k10.Characters(Start:=1, Length:=Len(f7.Value)).Font
.Name = f7.Font.Name
.FontStyle = f7.Font.FontStyle
.Size = f7.Font.Size
.Color = f7.Font.Color
End With
With k10.Characters(Start:=Len(f7.Value) + 1, Length:=Len(h7.Value)).Font
.Name = h7.Font.Name
.FontStyle = h7.Font.FontStyle
.Size = h7.Font.Size
.Color = h7.Font.Color
End With
End Sub 保留
页:
[1]