VBA 专辑之一

wp231957 · 发表于 2020-5-19 09:18:46

马上注册，结交更多好友，享用更多功能^_^

您需要登录才可以下载或查看，没有账号？立即注册

x

本帖最后由 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 [Sheet2$a1:a16]"
   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 [Sheet1$a2:c2000]"
   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 [mm$]"
   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 [rx$]"
   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 [mm$]"
   Windows(ThisWorkbook.Name).Activate
   Sheets("mm").Range("a" & row1).CopyFromRecordset cnn.Execute(Sql)
   Sql = "select  * from [rx-lucuku$]"
   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 [mm$]"
   Windows(ThisWorkbook.Name).Activate
   Sheets("mm").Range("a" & row1).CopyFromRecordset cnn.Execute(Sql)
   Sql = "select  * from [rx-lucuku$]"
   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、关于listbox textbox split ubound 的部分用法

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:53

全选复制？

wp231957 · 发表于 2020-5-19 09:40:48

永恒的蓝色梦想发表于 2020-5-19 09:28
全选复制？

嗯，最后恢复时，剪贴板是空的，白忙乎了

wp231957 · 发表于 2020-6-10 09:43:35

本帖最后由 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 [sheet1$a:a] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] b on a.A列=b.C列"
   Sheets(1).Range("h2").CopyFromRecordset cnn.Execute(Sql)
   '右连接测试
   Sql = "select a.A列,b.C列 from [sheet1$a:a] a right join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] b on a.A列=b.C列"
   Sheets(1).Range("k2").CopyFromRecordset cnn.Execute(Sql)
   
    '根据左连接取两列相同
   Sql = "select b.C列 from [sheet1$a:a] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] 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 [sheet1$a:a] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] b on a.A列=b.C列"
   Sheets(1).Range("h2").CopyFromRecordset cnn.Execute(Sql)
   '右连接测试
   Sql = "select a.A列,b.C列 from [sheet1$a:a] a right join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] 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 [sheet1$h:i] 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 [sheet1$k:l] 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 [sheet1$a:a] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] 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 [sheet1$a:a] a right join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] 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 [sheet1$a:a] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.FullName & "].[sheet1$c:c] b on a.A列=b.C列"
   Sheets(1).Range("l2").CopyFromRecordset cnn.Execute(Sql)
   cnn.Close
End Sub

wp231957 · 发表于 2020-6-11 09:26:36

本帖最后由 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

wp231957 · 发表于 2020-6-11 16:33:33

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

wp231957 · 发表于 2020-6-19 15:09:09

测试左连接中使用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 [122$a:d] a left join [Excel 12.0;hdr=1;imex=1;Database=" & ThisWorkbook.Path & "\数据.xls" & "].[sheet1$a3:h13] b on a.编码=int(right(b.编码,10))"
   Sheets(1).Range("a15").CopyFromRecordset cnn.Execute(Sql)
   cnn.Close
End Sub

wp231957 · 发表于 2020-6-23 09:18:36

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

wp231957 · 发表于 2020-6-23 15:32:30

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

Python初学者8号 · 发表于 2020-6-24 08:35:36

66666666666

wp231957 · 发表于 2020-7-6 09:54:51

复制带有超级链接的单元格

Sub wp()
   Sheets(1).Range("g5").Copy
   Sheets(2).Activate
   Sheets(2).Range("g7").Select
   ActiveSheet.Paste

End Sub

wp231957 · 发表于 2022-10-27 10:35:40

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-31 10:31:21

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-11-1 16:09:43

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

dsshenm · 发表于 2023-7-3 21:49:46

保留

账号		自动登录	找回密码
密码			立即注册

[学习笔记] VBA 专辑之一

马上注册，结交更多好友，享用更多功能^_^

本帖被以下淘专辑推荐: