虫部落

职场中常用的Excel VBA代码集中营

查看: 1921|回复: 13
简单就好 发表于 2019-4-27 22:53:51 |阅读模式
对于职场Excel用户来说,每天都需要与Excel打交道,如果能够用好常用的VBA代码,可以在一定程度上提高工作效率,让复杂重复的事情况简单便捷。

本人作为Excel爱好者,也常常收集些职场常用的VBA代码,在这和虫友们一起分享,也希望如果您也有其他常用的VBA代码跟贴分享,一起创建Excel VBA代码库


1、Excel十字光标代码

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex=xlNone
    Rows(Target.Row).Interior.Color = RGB(255, 0, 0)
    Columns(Target.Column).Interior.Color = RGB(0, 0, 255)
End Sub
注意:行与列的颜色条可以自己修改颜色,由RGB(X,Y,Z)设定。

2、显示所有隐藏的工作表

Sub 显示所有隐藏的工作表()
        Dim N As Long
        For N = 1 To Sheets.Count
                Sheets(N).Visible = True
        Next
End Sub

3、Excel将一个工作表根据条件拆分成多个工作簿

Sub CFGZB()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="请选择标题行:", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头,必须是第一行,且为一个单元格,如:“姓名”", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "数据源" Then
            Sheets(i).Delete
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("数据源").UsedRange.Rows.Count
    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k) 
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
        Dim Nowbook As Workbook
        Set Nowbook = Workbooks.Add
        With Nowbook
            With .Sheets(1)
                .Name = k(i)
                For num = 1 To UBound(myArray)
                    .Cells(1, num) = myArray(num, 1)
                Next num
                .Range("A2").CopyFromRecordset conn.Execute(Sql)
            End With
        End With
        ThisWorkbook.Activate
        Sheets(1).Cells.Select
        Selection.Copy
        Workbooks(Nowbook.Name).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)
        Nowbook.Close True
        Set Nowbook = Nothing
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

VBA操作方法
按"Alt+F11"组合键,打开VBA编辑窗口,依次选择"插入——模块",在右侧窗格插入一个空白模块,将相应代码复制粘贴;
关闭VBA编辑窗口,按按"Alt+F8"组合键,打开"宏"对话框,选择运行宏即可实现相应操作。
如有不明白,欢迎留言关注。

 楼主| 简单就好 发表于 2019-4-29 12:19:38
对筛选后的某列进行序号填充
Sub 对筛选后的某列进行填充()
        Dim M As Long, N As Long
        For M = 2 To Selection.Count
                If Selection(M).EntireRow.Hidden = False Then
                        N = N + 1
                        Selection(M) = N
                End If
        Next
End Sub
QQ截图20190429121818.png
 楼主| 简单就好 发表于 2019-4-27 22:55:30
Excel文件自杀代码

Private Sub Workbook_Open()
chk = GetSetting("hhh", "budget", "date", "")
If chk = "" Then
termdate = "2011-05-01"
MsgBox "本工作簿只能使用到" & termdate & vbCrLf & "超过期限将自动销毁!", vbExclamation
SaveSetting "hhh", "budget", "date", termdate
Else
If CDate(chk) <= Now Then
DeleteSetting "hhh", "budget", "date"
killme
Else
MsgBox "本工作簿只能使用到" & CDate(chk) & vbCrLf & "超过期限将自动销毁!", vbExclamation
End If
End If

End Sub

Public Sub killme()
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End Sub
 楼主| 简单就好 发表于 2019-4-27 22:58:21
多工作簿汇总到一个表

Sub CltSheets()
   Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K&
  Dim Sht As Worksheet, Sh As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show Then P = .SelectedItems(1) Else: Exit Sub
  End With
  If Right(P, 1) <> "\" Then P = P & "\"
  Keystr1 = InputBox("请输入工作簿名称所包含的关键词" & vbCr & "关键词可以为空,如为空,则默认选择全部工作簿")
  If StrPtr(Keystr1) = 0 Then Exit Sub '如果用户点击了取消或关闭按钮,则退出程序
  Keystr2 = InputBox("请输入工作表名称所包含的关键词" & vbCr & "关键词可以为空,如为空,则默认选择符合条件工作簿的全部工作表")
  If StrPtr(Keystr2) = 0 Then Exit Sub
  Set Sh = ActiveSheet '当前工作表,赋值变量,代码运行完毕后,回到此表
  Bookn = Dir(P & "*.xls*")
  Do While Bookn <> ""
    If Bookn = ThisWorkbook.Name Then
      MsgBox "注意:指定文件夹中存在和当前表格重名的工作簿!!" & vbCr & "该工作簿无法打开,工作表无法复制"
     '当出现重名工作簿时,提醒用户
    Else
      If InStr(1, Bookn, Keystr1, vbTextCompare) Then
     '工作簿名称是否包含关键词,关键词不区分大小写
        With GetObject(P & Bookn)
          For Each Sht In .Worksheets
            If InStr(1, Sht.Name, Keystr2, vbTextCompare) Then
           '工作表名称是否包含关键词,关键词不区分大小写
              If Application.CountIf(Sht.UsedRange, "<>") Then
             '如果表格存在数据区域
                Shtname = Split(Bookn, ".xls")(0) & "-" & Sht.Name
               '复制来的工作表以"工作簿-工作表"形式起名
                ThisWorkbook.Sheets(Shtname).Delete
               '如果已存在相关表名,则删除
                Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
                K = K + 1
               '复制Sht到代码所在工作簿所有工作表的后面,并累计个数
                ActiveSheet.Name = Shtname
               '工作表命名
              End If
            End If
          Next
          .Close False '关闭工作簿
        End With
      End If
    End If
    Bookn = Dir '下一个符合条件的文件
  Loop
  Sh.Select '回到初始工作表
  MsgBox "工作表收集完毕,共收集:" & K & "个"
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
 楼主| 简单就好 发表于 2019-4-27 22:59:27
如何将一个Excel工作表的数据拆分成多个工作表

Sub 如何将一个Excel工作表的数据拆分成多个工作表()
    Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object
    Dim k, t, Str As String, i As Long, lc As Long
    Application.ScreenUpdating = False '关闭屏幕更新
    Arr = Range("A1").CurrentRegion.Value
    lc = UBound(Arr, 2) '求取最后一列的列号
    Set Rng = Rows(1) '标题行
    Set Dic = CreateObject("Scripting.Dictionary") '创建字典
    For i = 2 To UBound(Arr)
        Str = Arr(i, 3) '订单号,关键字
        If Not Dic.Exists(Str) Then '如果字典没有关键字
            Set Dic(Str) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中
        Else '否则(字典中存在关键字)
            Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc)) '把行连合起来
        End If
    Next
    k = Dic.Keys '字典关键字集合
    t = Dic.Items '字典项目集合
    On Error Resume Next
    With Sheets
        For i = 0 To Dic.Count - 1 '循环关键字的个数
            Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字)
            If Sht Is Nothing Then '该工作表不存在则插入一个空工作表
                .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后,并命名为关键字
                Set Sht = ActiveSheet '活动工作表给变量
            Else '否则
                Sht.Cells.Clear '清除工作中所有内容和格式
            End If
            Rng.Copy Sht.Range("A1") '把标题写入第一行
            t(i).Copy Sht.Range("A2") '写入其他内容
            Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽
            Set Sht = Nothing '变量处于初始状态
        Next
    End With
    Sheets(1).Activate '第1个工作表处于激活状态
    Application.ScreenUpdating = True '打开屏幕更新
End Sub
流年再无小新 发表于 2019-4-27 23:00:36
慢慢学习啊啊啊谢谢
 楼主| 简单就好 发表于 2019-4-27 23:02:22
更改Excel标题状态栏代码

Private Sub Workbook_Activate()
On Error Resume Next
Application.Caption = "让高效办公流行起来" '改变EXCEL左上标题
Sheets("首页").Select '并定位在窗口上。。。。。。
Application.StatusBar = "本系统登录时间: " & Year(Now()) & "年" & Month(Now()) & "月" & Day(Now()) & "日" & "(" & Hour(Now()) & ":" & Minute(Now()) & ":" & Second(Now()) & ")" & " 〓★〓【请关注微信公众号:E同学Excel】〓★〓 " & W
End Sub

Antlion 发表于 2019-4-27 23:18:37
虽然不懂VBA但是给你点个赞
mrpathetic 发表于 2019-4-28 06:38:44
第一个代码有一个bug,使用以后,表格就不能再单元格内填充颜色了,已经填充了颜色的会自动被取消
 楼主| 简单就好 发表于 2019-4-28 09:11:06

一起相互交流学习
 楼主| 简单就好 发表于 2019-4-28 09:12:35
Antlion 发表于 2019-4-27 23:18
虽然不懂VBA但是给你点个赞

一般不需要真去懂VBA,只需要把它当成一个工具一样会使用就可以了,自己去学VBA是件非常痛苦的事
 楼主| 简单就好 发表于 2019-4-28 09:18:36
mrpathetic 发表于 2019-4-28 06:38
第一个代码有一个bug,使用以后,表格就不能再单元格内填充颜色了,已经填充了颜色的会自动被取消 ...

是的 ,一般情况第一个代码真的不建议去用,因为如果是使用WPS的伙伴,里面有一个阅读模式就是这种聚光灯效果
本代码主要是针对Office用户,想要用到这种聚光灯效果而设立的,在数据核对需要用到的时候可以用一用,平时就不要使用了

WPS阅读模式

WPS阅读模式
赞助商作品
虫子 更新于 2019年3月1日 23:33 来自 HUAWEI Mate X
如何高效地使用搜索引擎?

对于同一个问题,不同的人使用相同的搜索引擎可能搜索出不同的内容,经常出现在百度,谷歌上搜不到自己想要的内容的状况,那么究竟怎样搜索才可以准确的找到自己想找的内容?

落叶随风 发表于 2019-4-28 10:16:12
曾经去学过VBA感觉太痛苦了。
 楼主| 简单就好 发表于 2019-4-29 12:21:29
落叶随风 发表于 2019-4-28 10:16
曾经去学过VBA感觉太痛苦了。

是的,所以收集些职场常用VBA非常有必要,不需要懂VBA只需要会用VBA即可
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

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