excel无法在未启用宏的工作簿中保存以下功能_EXCEL — 实用的VBA

a971d4bd14168322b75456b6275b004d.png

虽说现在VBA真的是毫无排面,但只要会启用「宏」,收藏几个复制粘贴就能用的代码,作为一名办公室民工,总有用得上的时候。

所以这里记录几个之前工作中高频使用的小小小脚本。

下面提到的工作簿,即单个的 .xlsx.xls 文件,工作表就是文件里的 sheet

1、自定义函数

自定义一个 Countcolor() 函数,统计区域内指定颜色的单元格个数。

无情,知乎的代码块提供了几十种语言,就是没有VB……

Function Countcolor(arr As Range, c As Range)
    Dim rng As Range
    For Each rng In arr
        If rng.Interior.Color = c.Interior.Color Then
            Countcolor = Countcolor + 1
        End If
    Next rng
End Function

函数说明:

比如在单元格输入 =countcolor(B2:F16,B8),会返回区域 (B2:F16) 内与 B8 单元格颜色相同的单元格数。

b7a3d94e16c2b67f2c49f38a5df2f978.png

2、合并工作簿

依次打开某个文件夹下的 EXCEl 工作簿,将每一个工作簿下所有 Sheets 复制到当前的工作簿中。

04930d358fcb4380bd84c68217baf4a2.png
Sub BooksMerge()
    Dim FileOpen
    Dim X As Integer
    Application.ScreenUpdating = False

    FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft_Excel文件(*.xls*),*.xls*", MultiSelect:=True, Title:="合并工作薄")
    X = 1
    While X <= UBound(FileOpen)      ' UBound():返回数组最大下标
        Workbooks.Open Filename:=FileOpen(X)
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    X = X + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
errhadler:
    MsgBox Err.Description
End Sub

3、合并工作表

新建一个空白的 sheet,把工作簿下所有 Sheet 里的数据按顺序逐行复制到这个新建的空白表格中。

比如2019年上证指数的行情数据,按季度分在了4张工作表里,这里希望把它们合在一个表格里:

69d36de5d7d18797d0acff82ad89b257.png

复制以下代码:

Sub SheetsMerge()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sheets_pre As Integer, sheets_aft As Integer

    sheets_pre = Sheets.Count

    '删除空白的的工作表,如无必要,这步可省略
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Cells.Find(What:="1") Is Nothing And sht.Name <> "0" Then
            sht.Delete
        End If
    Next

    '在第一位新建一个空白汇总表,表名"2019年汇总"
    ThisWorkbook.Sheets.Add Before:=Worksheets(1)
    ActiveSheet.Name = "2019年汇总"
    
    '把第一张表包括表头(第一行)复制到汇总表
    For i = 1 To Sheets(2).Range("A65536").End(xlUp).Row
        Sheets(2).Rows(i).Copy Rows(i)
    Next
    
    '把后面的表去掉表头后复制到汇总表,
    For j = 3 To Sheets.Count
        If Sheets(j).Name <> ActiveSheet.Name Then
            Y = Sheets(j).Range("A65536").End(xlUp).Row
            X = Range("A65536").End(xlUp).Row
            For i = 1 To Y
                Sheets(j).Rows(i + 1).Copy Rows(X + i)
            Next
        End If
    Next
    
    Range("B1").Select
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    sheets_aft = Sheets.Count - 1
    
    '完成后弹出窗口提示
    MsgBox "当前工作簿下的全部工作表已经合并完毕!" & vbCrLf & _
           "共有" & sheets_pre & "张表," & "合并了" & sheets_aft & "张。"
End Sub

保存后,执行「宏」,效果应该是这样的:

7ce9f16e0fd95772b086272984a29788.png

4、分组后拆分到工作表

把一个表格里的数据,按某一列分组,每一组的数据复制到一张新的工作表中。

比如:继续前面的2019年上证指数行情数据,在第一列新增「月份」字段,现在希望每个月的行情数据单独放在一张 Sheet 里。

c3692d34abaf5d387e4fa6d698fbb667.png

复制以下代码:

Sub Sheetsplit()

    Dim arr, rngHead As Range, rngTotal As Range, d As Object, _
    k, t, r&, i&, lr&, lc%, sh As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    arr = Range("a1").CurrentRegion
    lr = UBound(arr)
    lc = UBound(arr, 2)
    
    Set rngHead = Rows(1)
    Set rngTotal = Rows(lr)
    Set d = CreateObject("scripting.dictionary")
    
    For i = 2 To lr - 1
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(, lc)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(, lc))
        End If
    Next
    
    k = d.Keys
    t = d.Items
    
    With Sheets
        For i = 0 To d.Count - 1
            With .Add(After:=.Item(.Count))
                .Name = k(i)
                rngHead.Copy .[a1]
                .Cells(1, 1).Resize(, lc).Columns.AutoFit
                t(i).Copy .[a2]
            End With
        Next
    End With
    
    Sheets(1).Activate
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

保存后,执行「宏」,效果应该是这样的:

e65876dddfc5b4e6ea5c0abbb7e316e9.png

5、工作表保存为工作簿

EXCEL 文件里每一张 Sheet 单独保存为一个工作簿。

比如:继续使用前面的行情数据,把每个月的行情保存为单独的一个 EXCEL 文件。

复制以下代码:

Sub Booksplit()

   Application.ScreenUpdating = False
   
   Dim folder As String
   folder = ThisWorkbook.Path & "" & "Index"
   
   If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
   
   Dim sht As Worksheet
   For Each sht In Worksheets
       If sht.Name <> "" Then
           sht.Copy
           ActiveWorkbook.SaveAs folder & "" & sht.Name
           ActiveWorkbook.Close
       End If
   Next
   
   Application.ScreenUpdating = True
   
End Sub

保存后,执行「宏」,我们在同样的文件路径下会发现一个新的文件夹「Index」:

708837eb998286d870787d231b417def.png

打完,收工。

评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值