vba 专辑之二

wp231957 · 发表于 2020-5-23 20:38:04

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

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

x

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

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

关于sheets的一些用法

Sub wp()
   MsgBox Sheets.Count  '工作表数量
   Set d2 = CreateObject("scripting.dictionary")  '字典引用
   MsgBox Sheets(2).Name  '名字
   Sheets(1).Name = "wp1"  '改变名字
   Sheets(2).Name = "wp2"
   Sheets(1).Tab.ColorIndex = 7   ' 标签颜色
   Sheets(1).Tab.ColorIndex = 5
End Sub

切换当前sheet是否显示表格线
当然，你也可以去选项配置--高级去手工设置

Sub 宏3()
    Sheet2.Activate
    ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)  'ActiveWindow.DisplayGridlines = True  显示  false 不显示
End Sub

关于copy外部工作簿的sheet到宏所在工作簿的一些

Sub 宏1()
    Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
    
    flag = 0
    For Each sht In Sheets      '检索name=####的工作表是否在sheets集合
       If sht.Name = "####" Then
          flag = 1
          Exit For
       End If
    Next
    If flag = 0 Then
       Sheets.Add().Name = "####"    '增加sheet
    End If
    For Each sht In Sheets           '除name=#### 之外的所有sheet 全部删除
        If sht.Name <> "####" Then
           sht.Delete
        End If
    Next
    Dim wb As Workbook
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "1table.xls")    '打开外部工作簿
    Windows("1Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)      '复制sheets(1) 到宏所在工作簿
    Windows("1Table.xls").Activate                         '关闭已打开的工作簿
    ActiveWindow.Close
    
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "2table.xls")
    Windows("2Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)
    Windows("2Table.xls").Activate
    ActiveWindow.Close
    
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "3table.xls")
    Windows("3Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=Workbooks("汇总表格.xlsx").Sheets(1)
    Windows("3Table.xls").Activate
    ActiveWindow.Close
    
    Sheets("1table").Name = "a1"      '重新命名
    Sheets("2table").Name = "b2"
    Sheets("3table").Name = "c3"
    Sheets("####").Delete             '多余的####删除
    
End Sub

关于copy外部工作簿的sheet到宏所在工作簿的一些，以及新建工作簿到新建表到保存

Sub 宏1()
    Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
    
    Dim wkb As Workbook
    Set wkb = Workbooks.Add
    wkb.SaveAs Filename:="d:\123.xlsx"
    
    Dim wb As Workbook
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "1table.xls")    '打开外部工作簿
    Windows("1Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=wkb.Sheets(1)
    Windows("1Table.xls").Activate                         '关闭已打开的工作簿
    ActiveWindow.Close
    
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "2table.xls")
    Windows("2Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=wkb.Sheets(1)
    Windows("2Table.xls").Activate
    ActiveWindow.Close
    
    Set wb = Workbooks.Open(ThisWorkbook.Path & "" & "3table.xls")
    Windows("3Table.xls").Activate
    Sheets(1).Select
    Sheets(1).Copy After:=wkb.Sheets(1)
    Windows("3Table.xls").Activate
    ActiveWindow.Close
    
    Sheets("1table").Name = "a1"      '重新命名
    Sheets("2table").Name = "b2"
    Sheets("3table").Name = "c3"
    Sheets("sheet1").Delete             '多余的删除
    
    wkb.Activate
    wkb.Save
    ActiveWindow.Close
    
End Sub

乘号 · 发表于 2020-5-23 20:52:58

沙发

wp231957 · 发表于 2020-5-25 15:51:27

本帖最后由 wp231957 于 2020-5-26 18:35 编辑

把这个代码添加，应该就可以解决闪屏的问题了，至于什么是闪屏，知者自知

Application.ScreenUpdating = False '关闭屏幕更新

关于区域复制粘贴，剪切等操作

Sub wp()
   Range("a1:b5").Select
   Set bs = Selection
   bs.Copy
   Range("a6:b" & Range("A65536").End(xlUp).Row).Select
   Set bs2 = Selection
   bs2.Cut
   Range("A1").Select
   ActiveSheet.Paste
End Sub

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

=TEXT(F3,"[$-130000]YYYY-M-D")

判断平年闰年的（农历）

=IF(TEXT(2020+1 &"-2","[$-130000]m")="13","闰年","平年")

在两个工作簿之间切换，获取当前工作簿的名字

Sub wp()
   Application.DisplayAlerts = False   '退出excel 不抛出提示框,当然改动也不会存盘
   Application.ScreenUpdating = False '关闭屏幕更新
   Dim wkb As Workbook
   Set wkb = Workbooks.Add
   wkb.SaveAs Filename:="d:\123.xlsx"
   Windows(ThisWorkbook.Name).Activate
   Range("a1:b5").Copy
   Windows("123.xlsx").Activate
   Sheets(1).Range("a1").Select
   ActiveSheet.Paste
   Windows(ThisWorkbook.Name).Activate
   end_row = Range("A65536").End(xlUp).Row
   If end_row > 5 Then
        Range("a1:b5").Clear
        Range("a6:b" & end_row).Select
        Set bs2 = Selection
        bs2.Cut
        Range("A1").Select
        ActiveSheet.Paste
   Else
        Range("a1:b5").Clear
        
   End If
   wkb.Save
   wkb.Close
   
End Sub

获取合并单元格所占用的行数

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

vba中使用excel函数SUMIF应用

Sub wp()
  srxm = Range("a4").MergeArea.Rows.Count
  Range("j4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "现金", Range("h4:h" & srxm - 1))
  Range("k4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "建行", Range("h4:h" & srxm - 1))
  Range("l4") = WorksheetFunction.SumIf(Range("e4:e" & srxm - 1), "公户", Range("h4:h" & srxm - 1))
  
  Range("r4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "现金", Range("p4:p" & srxm - 1))
  Range("s4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "建行", Range("p4:p" & srxm - 1))
  Range("t4") = WorksheetFunction.SumIf(Range("m4:m" & srxm - 1), "公户", Range("p4:p" & srxm - 1))
End Sub

vba中使用excel函数COUNTBLANK应用

Sub test()
  Range("k1:k22").Select
  tmp = 1
  For i = 1 To Selection.Rows.Count
     If WorksheetFunction.CountBlank(Range("k" & i)) = 0 Then
        Range("l" & i) = WorksheetFunction.CountBlank(Range("k" & tmp & ":" & "k" & i))
        tmp = i
     End If
     
  Next
End Sub

vba条件隐藏行

Sub a()
    Dim rg As Range
    Application.ScreenUpdating = False
    Sheets("sheet1").Range("g3:g56").Select
    For Each rg In Selection
        If rg.Value = "null" Or rg.Value = "" Then
             rg.EntireRow.Hidden = True
        End If
    Next rg
    Application.ScreenUpdating = True
End Sub

wp231957 · 发表于 2020-5-27 09:18:08

字典的用法随机数的用法扫描横向最右侧无数据单元格

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

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

wp231957 · 发表于 2020-6-19 15:57:16

标记单元格底色利用字典查找完全一致

Sub wp()
   Set da = CreateObject("scripting.dictionary")
   Set Db = CreateObject("scripting.dictionary")
   arr = Sheets(1).Range("a1:c26")
   brr = Sheets(2).Range("a1:c26")
   For i = 1 To UBound(arr)
     da(arr(i, 1) & arr(i, 2) & arr(i, 3)) = ""
     Db(brr(i, 1) & brr(i, 2) & brr(i, 3)) = ""
   Next
   For i = 1 To UBound(arr)
     tmp = brr(i, 1) & brr(i, 2) & brr(i, 3)
     If da.exists(tmp) Then
         Sheets(2).Range("a" & i, "c" & i).Interior.Color = 65535
     End If
     tmp2 = arr(i, 1) & arr(i, 2) & arr(i, 3)
     If Db.exists(tmp2) Then
         Sheets(1).Range("a" & i, "c" & i).Interior.Color = 65535
     End If
   Next
End Sub

wp231957 · 发表于 2020-6-21 15:13:59

sheet TO 工作簿的操作

Sub wp()
   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Dim wb As Workbook
   For Each x In Sheets()
     x.Copy
     Set wb = ActiveWorkbook
     wb.SaveAs ThisWorkbook.Path & "" & x.Name & ".xlsx"
     wb.Close
   Next
   
End Sub

wp231957 · 发表于 2020-6-23 09:32:42

隐藏工作表，数据并不会被隐藏

Sub 查找()
  Sheets("数据").Visible = False
  Debug.Print Sheets("数据").Range("d15").Value
End Sub

Sheets("数据").Visible = True 应该就是取消隐藏

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

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

wp231957 · 发表于 2020-7-3 08:49:29

Application.WorksheetFunction.RandBetween(1000, 9999)

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

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

A小明同学 · 发表于 2021-6-1 17:28:20

顶顶，好帖

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

[学习笔记] vba 专辑之二

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

本帖被以下淘专辑推荐: