鱼C论坛

 找回密码
 立即注册
查看: 4274|回复: 20

[学习笔记] VBA 专辑 之三

[复制链接]
发表于 2020-5-28 14:11:35 | 显示全部楼层 |阅读模式

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

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

x
本帖最后由 wp231957 于 2023-1-13 14:40 编辑

专辑一  戳这里
专辑二  戳这里
专辑四   请戳这里前进

打开文件对话框,可以多选文件
  1. Sub wp()
  2.    Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
  3.    Application.ScreenUpdating = False '关闭屏幕更新
  4.    
  5.    Dim f
  6.    f = Application.GetOpenFilename("EXCEL文档,*.xls,EXCEL文档,*.xlsx", 2, MultiSelect:=True)
  7.    Dim wb As Workbook
  8.    For x = 1 To UBound(f)
  9.         Set wb = Workbooks.Open(f(x))    '打开外部工作簿
  10.         Windows(wb.Name).Activate
  11.         arr = Sheets(1).Range("c1:c12")
  12.         Windows(ThisWorkbook.Name).Activate
  13.         col = Cells(1, 256).End(xlToLeft).Column
  14.         Cells(1, col + 1).Resize(UBound(arr, 1)) = arr
  15.         wb.Close
  16.    Next
  17.    'Stop
  18. End Sub
复制代码

本帖被以下淘专辑推荐:

想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复

使用道具 举报

 楼主| 发表于 2020-5-28 19:53:24 | 显示全部楼层
本帖最后由 wp231957 于 2020-5-31 19:29 编辑

在sheets 的末尾 插入sheet
  1. Sub wp()
  2.   'Debug.Print Sheets.Count
  3.   
  4.   Sheets.Add(after:=Sheets(Sheets.Count)).Name = Format(Now(), "yyyymmdd")
  5.   
  6. End Sub
复制代码


如何判断一个sheet是否是空表
  1. Sub wp2()
  2.    For Each x In Sheets
  3.      If IsEmpty(x.UsedRange) Then
  4.         Debug.Print x.Name & "  是一个空表"
  5.      Else
  6.         Debug.Print x.Name & "  表存在数据"
  7.      End If
  8.    Next
  9. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-5-31 19:46:30 | 显示全部楼层
一个函数,判断某个工作簿当前是否打开状态

  1. Function isworkbookopen(bookname As String) As Boolean
  2.    On Error Resume Next
  3.    Dim wkb As Object
  4.    Set wkb = Workbooks(bookname) '如果工作簿没有打开,则会引发错误处理
  5.    If Err.Number = 0 Then
  6.       isworkbookopen = True
  7.    Else
  8.       isworkbookopen = False
  9.    End If
  10.    
  11. End Function
复制代码


测试案例:(实测通过)

  1. If isworkbookopen("123.xlsx") Then
  2.       Debug.Print "open"
  3.    Else
  4.       Debug.Print "需要打开"
  5.       Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "123.xlsx")    '打开外部工作簿
  6.    End If
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-2 14:57:04 | 显示全部楼层
本帖最后由 wp231957 于 2020-6-2 14:58 编辑

select where ... in .....子句中拼接字符串的示例

拼接演示:
: Sql : "select  * from [人员信息$a1:d15] where 姓名 in ('张三','李四')" : Variant/String
  1. Sub wp()
  2.    
  3.     arr = Split(Application.Trim(Range("a2").Value), " ")
  4.     Set Cnn = CreateObject("ADODB.Connection")
  5.     Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  6.     Sql = "select  * from [人员信息$a1:d15] where 姓名 in ('" & Join(arr, "','") & "')"
  7.     Sheets("查询").Range("a7:d1000").Clear
  8.     Sheets("查询").Range("a7").CopyFromRecordset Cnn.Execute(Sql)
  9. End Sub

复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-3 09:04:48 | 显示全部楼层
在所有sheet的D列之前插入新列,原D列 变更为E列

  1. Sub wp2()
  2.     For Each x In Sheets
  3.         x.Columns("D").EntireColumn.Insert
  4.     Next
  5. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-8 10:13:26 | 显示全部楼层
字典的应用之  挑选两列数据的重合部分 和非重合部分
  1. Sub wp()
  2.    Set da = CreateObject("scripting.dictionary")
  3.    Set Db = CreateObject("scripting.dictionary")
  4.    arr = Range("a1:a17")
  5.    brr = Range("b1:b17")
  6.    For i = 1 To UBound(arr)   '创建字典(初始化字典)
  7.      da(arr(i, 1)) = ""
  8.      Db(brr(i, 1)) = ""
  9.    Next
  10.    k = 1
  11.    l = 1
  12.    m = 1
  13.    For i = 1 To UBound(arr)
  14.      If da.exists(brr(i, 1)) Then       '扫描Brr数组中 与字典A 中一致的数据
  15.         Cells(k, 4) = brr(i, 1)
  16.         k = k + 1
  17.      Else
  18.         Cells(l, 5) = brr(i, 1)         'Brr数组中 有,但是字典A 中没有的数据
  19.         l = l + 1
  20.      End If
  21.      If Not Db.exists(arr(i, 1)) Then   'Arr数组中 有,但是字典B 中没有的数据
  22.         Cells(m, 6) = arr(i, 1)
  23.         m = m + 1
  24.      End If
  25.    Next
  26. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-9 09:06:05 | 显示全部楼层
把所有工作簿的表(仅包含一个工作表) 都复制到一个工作簿中,表名与原工作簿同名

  1. Sub wp()
  2.    Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
  3.    Application.ScreenUpdating = False '禁止刷屏
  4.    
  5.    Dim f
  6.    f = Application.GetOpenFilename("EXCEL文档,*.xls,EXCEL文档,*.xlsx", 1, MultiSelect:=True)
  7.    Dim wb As Workbook
  8.    For x = 1 To UBound(f)
  9.         Set wb = Workbooks.Open(f(x))    '打开外部工作簿
  10.         Windows(wb.Name).Activate
  11.         Sheets(1).Select
  12.         Sheets(1).Name = Left(wb.Name, Len(wb.Name) - 4)   '去除.XLS
  13.         Sheets(1).Copy after:=ThisWorkbook.Sheets(1)
  14.         wb.Close
  15.    Next

  16. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-9 11:55:51 | 显示全部楼层
区域数据拷贝

  1. Sub wp()
  2.     Application.DisplayAlerts = False
  3.     Dim wb As Workbook
  4.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "数据.xlsx")    '打开外部工作簿
  5.     Windows("数据.xlsx").Activate
  6.     Sheets(1).Activate
  7.     arr = Range("a2:d" & Range("A65536").End(xlUp).Row)
  8.     Windows(ThisWorkbook.Name).Activate
  9.     Sheets(1).Activate
  10.     Range("a2").Resize(UBound(arr, 1), 4) = arr
  11.     wb.Close
  12. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-9 13:46:27 | 显示全部楼层
字符串分割以及INSTR用法一例

  1. Sub wp()
  2.    s = "AAA_MM_gg-77-99_BB_sdfds"
  3.    If InStr(s, "AAA") Then
  4.      Debug.Print "合格的字符串"
  5.      arr = Split(s, "_")
  6.      For x = 1 To UBound(arr)
  7.        If InStr(arr(x), "-") Then
  8.           Debug.Print arr(x)
  9.        End If
  10.      Next
  11.    Else
  12.      Debug.Print "字符串非法"
  13.    End If
  14. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-9 14:15:23 | 显示全部楼层
字典应用之   按字体颜色累加目标单元格数值

  1. Sub wp()
  2.    arr = Range("c5:f13").Select
  3.    Set da = CreateObject("scripting.dictionary")
  4.    For Each x In Selection     '创建并初始化字典,也就是统计一下目标单元格区域中,包含几种颜色
  5.      If x(1) <> "" Then
  6.         da(x.Interior.ColorIndex) = 0   '初始化,因为要参与计算  所以不能赋值为空
  7.      End If
  8.    Next
  9.    For Each x In da.keys       '为每一种颜色 进行累加值
  10.      For Each a In Selection
  11.         If a.Interior.ColorIndex = x Then
  12.            da(x) = da(x) + a          '累加
  13.         End If
  14.      Next
  15.    Next
  16.    For Each x In da.keys
  17.      Debug.Print x & ":=" & da(x)   '输出
  18.    Next
  19. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-9 16:35:25 | 显示全部楼层
按行输出二维数组

  1. Sub wp()
  2.    Sheets("wp").Activate
  3.    arr = Range("A2:k6")
  4.    For x = 1 To 5
  5.         For I = LBound(arr, 2) To UBound(arr, 2)
  6.             Debug.Print arr(x, I);
  7.         Next
  8.         Debug.Print
  9.    Next
  10. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-15 08:54:01 | 显示全部楼层
本帖最后由 wp231957 于 2020-6-15 08:55 编辑

sql  where 子句 后面跟 range 的语法示例
单元格的清空
  1. Sub wp()
  2.    
  3.     arr = Split(Application.Trim(Range("a2").Value), " ")
  4.     Set Cnn = CreateObject("ADODB.Connection")
  5.     Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  6.     Sql = "select 日期,营业额 from [sheet2$a:c] where 姓名 =""" & Range("e1") & """"
  7.     Sheets("sheet2").Range(Cells(2, 5), Cells(Rows.Count, 6)).Clear
  8.     Sheets("sheet2").Range("e2").CopyFromRecordset Cnn.Execute(Sql)
  9. End Sub

复制代码


单元格区域清空的两种方法
range("a2:c65536").delete shift:=xlup
Sheets("sheet2").Range(Cells(2, 5), Cells(Rows.Count, 6)).Clear
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-17 09:19:46 | 显示全部楼层
本帖最后由 wp231957 于 2020-6-17 09:31 编辑

一维数组,二维数组 给range 赋值 时 用法

转置有行数限制 ,推荐使用二维数组,二维数组我测试100万行数据 无错误

  1. '二维数组 可以直接赋值
  2. Sub wp2()
  3.    Const M As Long = 100000
  4.    Dim arr(1 To M, 1 To 1)
  5.    For i = 1 To M
  6.      arr(i, 1) = i
  7.    Next
  8.    Sheets("sheet3").Range("a1:a" & M) = arr
  9. End Sub

  10. '一维数组  需要转置 才可以赋值给range   

  11. Sub wp3()
  12.    Const M As Long = 100000
  13.    Dim arr(1 To M)
  14.    For i = 1 To M
  15.      arr(i) = i
  16.    Next
  17.    Sheets("sheet3").Range("a1:a" & M).Resize(M, 1) = Application.Transpose(arr)
  18. End Sub
复制代码


想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-17 09:34:27 | 显示全部楼层
sql 语句测试   100万行 可以通过  获取记录行数

  1. Sub wp4()
  2.    Set Cnn = CreateObject("ADODB.Connection")
  3.    Set rst = CreateObject("adodb.recordset")
  4.    Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  5.    Sql = "select * from [Sheet3$]"
  6.    rst.cursorlocation = 3
  7.    rst.Open Sql, Cnn
  8.    
  9.    Debug.Print rst.RecordCount '返回记录数
  10.    Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
  11.   
  12. End Sub
复制代码


想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-22 08:56:47 | 显示全部楼层
vba  format 日期函数 一例
"yyyy/m/d"  这里用一个m 一个 d  来匹配 单个的月 日, 如果用MM  DD  则会出现前导0 的情况  ,视需求而选择
  1. Sub 按钮1_Click()
  2.    arr = Range("a2:c6")
  3.    Dim brr(1 To 5, 1 To 1)
  4.    For x = 1 To UBound(arr)
  5.       brr(x, 1) = arr(x, 1) & Format(arr(x, 3), "yyyy/m/d")
  6.    Next
  7.    Range("d2").Resize(5) = brr
  8. End Sub
复制代码

想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-22 14:55:46 | 显示全部楼层
解决日期显示的是一个整形数值得问题

  1. Sub wp4()
  2.    Set Cnn = CreateObject("ADODB.Connection")
  3.    Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  4.    Sql = "select distinct 日期,员工姓名 ,count(员工姓名) from [Sheet1$a1:s54] group by 日期,员工姓名"
  5.    Columns("D:D").NumberFormatLocal = "yyyy/m/d"
  6.    Sheets("sheet3").Range("d1").CopyFromRecordset Cnn.Execute(Sql)
  7.   
  8. End Sub

  9.    
  10.    
复制代码


想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-6-23 10:10:41 | 显示全部楼层
Sheet1.UsedRange.Rows.Autofit '使用范围内的行自动匹配行高
Sheet1.UsedRange.Columns.Autofit'使用范围内的列自动匹配列宽

想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 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
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 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
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

 楼主| 发表于 2020-7-7 08:57:26 | 显示全部楼层
双表联动更新 示例

  1. Sub wp()
  2.    Set Cnn = CreateObject("ADODB.Connection")
  3.    Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  4.    sql2 = "update [" & Sheets("主页").Range("A1") & "$] a inner join [主页$b2:d7] b on a.身份证号码=b.身份证号码 set a.身份证号码=b.更正编码"
  5.    Debug.Print sql2
  6.    Cnn.Execute (sql2)
  7.    Cnn.Close
  8. End Sub
复制代码
想知道小甲鱼最近在做啥?请访问 -> ilovefishc.com
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

小黑屋|手机版|Archiver|鱼C工作室 ( 粤ICP备18085999号-1 | 粤公网安备 44051102000585号)

GMT+8, 2024-3-29 23:28

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

快速回复 返回顶部 返回列表