设为首页收藏本站
切换到窄版

鱼C论坛

 找回密码
 立即注册
鱼C论坛»论坛 › 萌新训练营 › 萌新交流区 › vba 专辑之二
返回列表 发新帖
查看: 3673|回复: 13

[学习笔记] vba 专辑之二

[复制链接]
wp231957
发表于 2020-5-23 20:38:04 | 显示全部楼层 |阅读模式

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

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

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

专辑三   戳这里
专辑一，请戳这里前进
专辑四   请戳这里前进

关于sheets的一些用法
  1. Sub wp()
  2.    MsgBox Sheets.Count  '工作表数量
  3.    Set d2 = CreateObject("scripting.dictionary")  '字典引用
  4.    MsgBox Sheets(2).Name  '名字
  5.    Sheets(1).Name = "wp1"  '改变名字
  6.    Sheets(2).Name = "wp2"
  7.    Sheets(1).Tab.ColorIndex = 7   ' 标签颜色
  8.    Sheets(1).Tab.ColorIndex = 5
  9. End Sub
复制代码

切换当前sheet是否显示表格线
当然，你也可以去选项配置--高级 去手工设置
  1. Sub 宏3()
  2.     Sheet2.Activate
  3.     ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)  'ActiveWindow.DisplayGridlines = True  显示  false 不显示
  4. End Sub

复制代码


关于copy外部工作簿的sheet到宏所在工作簿的一些
  1. Sub 宏1()
  2.     Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
  3.    
  4.     flag = 0
  5.     For Each sht In Sheets      '检索name=####的工作表是否在sheets集合
  6.        If sht.Name = "####" Then
  7.           flag = 1
  8.           Exit For
  9.        End If
  10.     Next
  11.     If flag = 0 Then
  12.        Sheets.Add().Name = "####"    '增加sheet
  13.     End If
  14.     For Each sht In Sheets           '除name=#### 之外的所有sheet 全部删除
  15.         If sht.Name <> "####" Then
  16.            sht.Delete
  17.         End If
  18.     Next
  19.     Dim wb As Workbook
  20.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "1table.xls")    '打开外部工作簿
  21.     Windows("1Table.xls").Activate
  22.     Sheets(1).Select
  23.     Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)      '复制sheets(1) 到宏所在工作簿
  24.     Windows("1Table.xls").Activate                         '关闭已打开的工作簿
  25.     ActiveWindow.Close
  26.    
  27.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "2table.xls")
  28.     Windows("2Table.xls").Activate
  29.     Sheets(1).Select
  30.     Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)
  31.     Windows("2Table.xls").Activate
  32.     ActiveWindow.Close
  33.    
  34.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "3table.xls")
  35.     Windows("3Table.xls").Activate
  36.     Sheets(1).Select
  37.     Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)
  38.     Windows("3Table.xls").Activate
  39.     ActiveWindow.Close
  40.    
  41.     Sheets("1table").Name = "a1"      '重新命名
  42.     Sheets("2table").Name = "b2"
  43.     Sheets("3table").Name = "c3"
  44.     Sheets("####").Delete             '多余的####删除
  45.    
  46. End Sub
复制代码

关于copy外部工作簿的sheet到宏所在工作簿的一些，以及新建工作簿到新建表到保存
  1. Sub 宏1()
  2.     Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
  3.    
  4.     Dim wkb As Workbook
  5.     Set wkb = Workbooks.Add
  6.     wkb.SaveAs Filename:="d:\123.xlsx"
  7.    
  8.     Dim wb As Workbook
  9.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "1table.xls")    '打开外部工作簿
  10.     Windows("1Table.xls").Activate
  11.     Sheets(1).Select
  12.     Sheets(1).Copy After:=wkb.Sheets(1)
  13.     Windows("1Table.xls").Activate                         '关闭已打开的工作簿
  14.     ActiveWindow.Close
  15.    
  16.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "2table.xls")
  17.     Windows("2Table.xls").Activate
  18.     Sheets(1).Select
  19.     Sheets(1).Copy After:=wkb.Sheets(1)
  20.     Windows("2Table.xls").Activate
  21.     ActiveWindow.Close
  22.    
  23.     Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "3table.xls")
  24.     Windows("3Table.xls").Activate
  25.     Sheets(1).Select
  26.     Sheets(1).Copy After:=wkb.Sheets(1)
  27.     Windows("3Table.xls").Activate
  28.     ActiveWindow.Close
  29.    
  30.     Sheets("1table").Name = "a1"      '重新命名
  31.     Sheets("2table").Name = "b2"
  32.     Sheets("3table").Name = "c3"
  33.     Sheets("sheet1").Delete             '多余的删除
  34.    
  35.     wkb.Activate
  36.     wkb.Save
  37.     ActiveWindow.Close
  38.    
  39. End Sub

复制代码

本帖被以下淘专辑推荐:

小甲鱼最新课程 -> https://ilovefishc.com
回复

使用道具 举报

乘号
发表于 2020-5-23 20:52:58 | 显示全部楼层
沙发
小甲鱼最新课程 -> https://ilovefishc.com
回复

使用道具 举报

wp231957
 楼主| 发表于 2020-5-25 15:51:27 | 显示全部楼层
本帖最后由 wp231957 于 2020-5-26 18:35 编辑

把这个代码添加，应该就可以解决闪屏的问题了，至于什么是闪屏，知者自知
  1. Application.ScreenUpdating = False '关闭屏幕更新
复制代码


关于区域复制 粘贴，剪切 等操作
  1. Sub wp()
  2.    Range("a1:b5").Select
  3.    Set bs = Selection
  4.    bs.Copy
  5.    Range("a6:b" & Range("A65536").End(xlUp).Row).Select
  6.    Set bs2 = Selection
  7.    bs2.Cut
  8.    Range("A1").Select
  9.    ActiveSheet.Paste
  10. End Sub
复制代码


传说中的公历转农历函数，实测就是闰月会有些问题

  1. =TEXT(F3,"[$-130000]YYYY-M-D")
复制代码

判断平年闰年的（农历）
  1. =IF(TEXT(2020+1 &"-2","[$-130000]m")="13","闰年","平年")
复制代码

在两个工作簿之间切换，获取当前工作簿的名字
  1. Sub wp()
  2.    Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
  3.    Application.ScreenUpdating = False '关闭屏幕更新
  4.    Dim wkb As Workbook
  5.    Set wkb = Workbooks.Add
  6.    wkb.SaveAs Filename:="d:\123.xlsx"
  7.    Windows(ThisWorkbook.Name).Activate
  8.    Range("a1:b5").Copy
  9.    Windows("123.xlsx").Activate
  10.    Sheets(1).Range("a1").Select
  11.    ActiveSheet.Paste
  12.    Windows(ThisWorkbook.Name).Activate
  13.    end_row = Range("A65536").End(xlUp).Row
  14.    If end_row > 5 Then
  15.         Range("a1:b5").Clear
  16.         Range("a6:b" & end_row).Select
  17.         Set bs2 = Selection
  18.         bs2.Cut
  19.         Range("A1").Select
  20.         ActiveSheet.Paste
  21.    Else
  22.         Range("a1:b5").Clear
  23.         
  24.    End If
  25.    wkb.Save
  26.    wkb.Close
  27.    
  28. End Sub
复制代码

获取合并单元格所占用的行数
  1. MsgBox Range("a4").MergeArea.Rows.Count
  2. 如果有合并单元格，以下为真正的占行数
  3. Sub test()
  4.   tmp = Range("A65536").End(xlUp).Row
  5.   arr = Range("a4:a" & tmp)
  6.   Debug.Print UBound(arr) + Range("a" & tmp).MergeArea.Rows.Count - 1

  8. End Sub

复制代码

vba中使用excel函数SUMIF应用
  1. Sub wp()
  2.   srxm = Range("a4").MergeArea.Rows.Count
  3.   Range("j4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "现金", Range("h4:h" & srxm - 1))
  4.   Range("k4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "建行", Range("h4:h" & srxm - 1))
  5.   Range("l4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "公户", Range("h4:h" & srxm - 1))
  6.   
  7.   Range("r4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "现金", Range("p4:p" & srxm - 1))
  8.   Range("s4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "建行", Range("p4:p" & srxm - 1))
  9.   Range("t4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "公户", Range("p4:p" & srxm - 1))
  10. End Sub
复制代码

vba中使用excel函数COUNTBLANK应用
  1. Sub test()
  2.   Range("k1:k22").Select
  3.   tmp = 1
  4.   For i = 1 To Selection.Rows.Count
  5.      If WorksheetFunction.CountBlank(Range("k" & i)) = 0 Then
  6.         Range("l" & i) = WorksheetFunction.CountBlank(Range("k" & tmp & ":" & "k" & i))
  7.         tmp = i
  8.      End If
  9.      
  10.   Next
  11. End Sub
复制代码

vba条件隐藏行
  1. Sub a()
  2.     Dim rg As Range
  3.     Application.ScreenUpdating = False
  4.     Sheets("sheet1").Range("g3:g56").Select
  5.     For Each rg In Selection
  6.         If rg.Value = "null" Or rg.Value = "" Then
  7.              rg.EntireRow.Hidden = True
  8.         End If
  9.     Next rg
  10.     Application.ScreenUpdating = True
  11. End Sub
复制代码
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-5-27 09:18:08 | 显示全部楼层
字典的用法   随机数的用法   扫描横向最右侧无数据单元格

  1. Sub wp()
  2.     Dim d As Object
  3.     Dim s As Integer
  4.      
  5.     Randomize (Timer)           '初始化随机数
  6.     Set d = CreateObject("Scripting.Dictionary")
  7.    
  8.     For x = 1 To 20     '这里替换成500 ？？？
  9.         Do Until d.Count = 10
  10.             s = Int(Rnd * 10)
  11.             d(s) = ""
  12.         Loop
  13.         right_col = Cells(18, 256).End(xlToLeft).Column
  14.         Cells(18, right_col + 1).Resize(d.Count, 1) = Application.Transpose(d.Keys)
  15.         d.RemoveAll
  16.     Next
  17. End Sub

复制代码
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-17 15:56:08 | 显示全部楼层
vba 中使用asc +mid 函数 获取某个字符的码值

Debug.Print Asc(Mid(Range("a13").Value, 3, 1))

以下代码 遍历字符串  并输出每个字符的码值

Sub wp()
  For x = 1 To Len(Range("a13").Value)
      Debug.Print Asc(Mid(Range("a13").Value, x, 1))
  Next
End Sub


小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-19 15:57:16 | 显示全部楼层
标记单元格底色   利用字典查找完全一致

  1. Sub wp()
  2.    Set da = CreateObject("scripting.dictionary")
  3.    Set Db = CreateObject("scripting.dictionary")
  4.    arr = Sheets(1).Range("a1:c26")
  5.    brr = Sheets(2).Range("a1:c26")
  6.    For i = 1 To UBound(arr)
  7.      da(arr(i, 1) & arr(i, 2) & arr(i, 3)) = ""
  8.      Db(brr(i, 1) & brr(i, 2) & brr(i, 3)) = ""
  9.    Next
  10.    For i = 1 To UBound(arr)
  11.      tmp = brr(i, 1) & brr(i, 2) & brr(i, 3)
  12.      If da.exists(tmp) Then
  13.          Sheets(2).Range("a" & i, "c" & i).Interior.Color = 65535
  14.      End If
  15.      tmp2 = arr(i, 1) & arr(i, 2) & arr(i, 3)
  16.      If Db.exists(tmp2) Then
  17.          Sheets(1).Range("a" & i, "c" & i).Interior.Color = 65535
  18.      End If
  19.    Next
  20. End Sub


复制代码
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-21 15:13:59 | 显示全部楼层
sheet  TO  工作簿的操作

  1. Sub wp()
  2.    Application.DisplayAlerts = False
  3.    Application.ScreenUpdating = False
  4.    Dim wb As Workbook
  5.    For Each x In Sheets()
  6.      x.Copy
  7.      Set wb = ActiveWorkbook
  8.      wb.SaveAs ThisWorkbook.Path & "" & x.Name & ".xlsx"
  9.      wb.Close
  10.    Next
  11.    
  12. End Sub
复制代码
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-23 09:32:42 | 显示全部楼层
隐藏工作表，数据并不会被隐藏

  1. Sub 查找()
  2.   Sheets("数据").Visible = False
  3.   Debug.Print Sheets("数据").Range("d15").Value
  4. End Sub
复制代码


Sheets("数据").Visible = True  应该就是取消隐藏
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-23 12:20:52 | 显示全部楼层
取自动编号的最大id  有人说 不需要人工插入，但是实测 必须插入  所以取最大id+1 作为新id 插入
'录入按钮
Private Sub CommandButton1_Click()
   Set cnn = CreateObject("ADODB.Connection")
   cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库.mdb"
   Sql2 = "select max(id) from 数据"
   maxid = cnn.Execute(Sql2).Fields(0).Value + 1
   str = Split(Label6.Caption, " ")(0)    '这个是把长日期的 星期几  去掉  不知道为什么  #1900-01-01#  access能识别  而 #1900-01-01 星期?#  就无法识别
   Sql = "insert into  数据  values(" & maxid & "," & TextBox1.Text & "," & ComboBox1.Value & ",'" & ComboBox2.Value & "',#" & str & "#)"
   cnn.Execute (Sql)
   
End Sub
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-6-28 17:04:56 | 显示全部楼层
Function wp(rng)
  Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "[A-Z]+"
    reg.Global = True
    Set regfind = reg.Execute(rng.Value)
    If regfind.Count > 0 Then
       For Each m In regfind
         wp = wp & m & " "
       Next
    End If
    Set objRegEx = Nothing
End Function
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-7-3 08:49:29 | 显示全部楼层
Application.WorksheetFunction.RandBetween(1000, 9999)
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-7-8 14:38:22 | 显示全部楼层
批量写入工作簿  涉及到打开自身文档的相关问题
Sub wp2()

   Application.DisplayAlerts = False
   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)
        If Split(f(x), "\")(UBound(Split(f(x), "\"))) <> "11.xls" Then
           Set wb = Workbooks.Open(f(x))    '打开非本工作簿
           Windows(wb.Name).Activate
            gs = Split(Range("a1"), ":")(1)
            gg = Split(Range("a1"), ":")(0)
            zh = Split(Range("b1"), ":")(1)
            zg = Split(Range("b1"), ":")(0)
            Range("i2") = gg
            Range("j2") = zg
            Range("j:j").NumberFormatLocal = "@"
            Range("i3:i" & Range("c" & Rows.Count).End(xlUp).Row) = gs
            Range("j3:j" & Range("c" & Rows.Count).End(xlUp).Row) = zh
            wb.Save
            wb.Close True
        Else
           Set wb = Workbooks("11.xls")     '如果是THISWORKBOOK
           Windows("11.xls").Activate
           gs = Split(Range("a1"), ":")(1)
           gg = Split(Range("a1"), ":")(0)
           zh = Split(Range("b1"), ":")(1)
           zg = Split(Range("b1"), ":")(0)
           Range("i2") = gg
           Range("j2") = zg
           Range("j:j").NumberFormatLocal = "@"
           Range("i3:i" & Range("c" & Rows.Count).End(xlUp).Row) = gs
           Range("j3:j" & Range("c" & Rows.Count).End(xlUp).Row) = zh
           wb.Save
       End If
   Next
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

wp231957
 楼主| 发表于 2020-7-15 11:27:28 | 显示全部楼层
正则的基本使用方法
Sub wp()
    s = "单元格A1内容为“附件发的发发发很费劲25635第三方拉活动经费444444shfhe0345张三”      如何提取其中的数字并实现”25635，444444，0345”这样的文本效果    求大神帮忙"
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")
    objRegEx.Pattern = "\d+"
    objRegEx.Global = True
    Set objmh = objRegEx.Execute(s)
    For Each x In objmh
       Debug.Print x
    Next
    Set objRegEx = Nothing

End Sub
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

A小明同学
发表于 2021-6-1 17:28:20 | 显示全部楼层
顶顶，好帖
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

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

GMT+8, 2025-6-10 00:16

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

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