VBA 专辑之三

wp231957 · 发表于 2020-5-28 14:11:35

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

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

x

本帖最后由 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-28 19:53:24

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

wp231957 · 发表于 2020-5-31 19:46:30

一个函数，判断某个工作簿当前是否打开状态

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:57:04

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

wp231957 · 发表于 2020-6-3 09:04:48

在所有sheet的D列之前插入新列，原D列变更为E列

Sub wp2()
    For Each x In Sheets
        x.Columns("D").EntireColumn.Insert
    Next
End Sub

wp231957 · 发表于 2020-6-8 10:13:26

字典的应用之挑选两列数据的重合部分和非重合部分

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

wp231957 · 发表于 2020-6-9 09:06:05

把所有工作簿的表(仅包含一个工作表）都复制到一个工作簿中，表名与原工作簿同名

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

wp231957 · 发表于 2020-6-9 11:55:51

区域数据拷贝

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

wp231957 · 发表于 2020-6-9 13:46:27

字符串分割以及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

wp231957 · 发表于 2020-6-9 14:15:23

字典应用之按字体颜色累加目标单元格数值

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

wp231957 · 发表于 2020-6-9 16:35:25

按行输出二维数组

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:54:01

本帖最后由 wp231957 于 2020-6-15 08:55 编辑

sql where 子句后面跟 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 [sheet2$a:c] 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:19:46

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

wp231957 · 发表于 2020-6-17 09:34:27

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 [Sheet3$]"
   rst.cursorlocation = 3
   rst.Open Sql, Cnn
   
   Debug.Print rst.RecordCount '返回记录数
   Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
  
End Sub

wp231957 · 发表于 2020-6-22 08:56:47

vba format 日期函数一例
"yyyy/m/d" 这里用一个m 一个 d 来匹配单个的月日，如果用MM DD 则会出现前导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

wp231957 · 发表于 2020-6-22 14:55:46

解决日期显示的是一个整形数值得问题

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 [Sheet1$a1:s54] group by 日期,员工姓名"
   Columns("D:D").NumberFormatLocal = "yyyy/m/d"
   Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
  
End Sub

wp231957 · 发表于 2020-6-23 10:10:41

Sheet1.UsedRange.Rows.Autofit '使用范围内的行自动匹配行高
Sheet1.UsedRange.Columns.Autofit'使用范围内的列自动匹配列宽

wp231957 · 发表于 2020-6-28 14:00:09

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 [Sheet1$a:c] group by 日期,商品编号,商品单价"
sql = "select 商品编号,商品单价,销售数量,商品单价*销售数量  from (" & sql & ") "
Sheets("sheet1").Range("h2").CopyFromRecordset cnn.Execute(sql)

End Sub

wp231957 · 发表于 2020-6-29 16:46:10

神操作，单元格部分文本颜色的改变

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

wp231957 · 发表于 2020-7-7 08:57:26

双表联动更新示例

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

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

[学习笔记] VBA 专辑之三

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

本帖被以下淘专辑推荐:

[学习笔记] VBA 专辑 之三

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

本帖被以下淘专辑推荐:

[学习笔记] VBA 专辑之三