vba 专辑之二,萌新交流区,萌新训练营,鱼C论坛

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

vba 专辑之二

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

sheetTO工作簿的操作

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 = "+"
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

顶顶，好帖

页: [1]

鱼C论坛's Archiver

vba 专辑之二