Day4-跟着孙兴华学习Excel VBA 第一季

qq_45526868

已于 2024-02-19 22:39:32 修改

阅读量350

点赞数 5

文章标签：学习 excel 开发语言

于 2024-02-19 22:38:54 首次发布

本文链接：https://blog.csdn.net/qq_45526868/article/details/136178816

版权

本文详细介绍了使用VBA在Excel中实现的功能，包括按指定列拆分工作表，批量将工作簿转换为独立文件，以及选中单元格时自动填充颜色。通过提供的VBA代码，用户可以灵活管理Excel数据并提高工作效率。

摘要由CSDN通过智能技术生成

第16节按任意列拆分方法二

基于15节的代码

原表

代码1（第15节所用到代码）

Sub SplitShts()
    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range, aRef, strYesOrNo As String
    Dim strKey As String, strTemp As String
    On Error Resume Next '忽略错误，程序继续运行
    Set d = CreateObject("scripting.dictionary")
    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    '用户选择的拆分依据列
    lngGistCol = rngGist.Column
    '拆分依据列的列标
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))
    '用户设置总表的标题行数
    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    strYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)
    Set rngData = rngGist.Parent.UsedRange
    '总表的数据区域
    Set rngFormat = rngGist.Parent.Cells
    '总表的单元格区域用于粘贴总表格式
    aData = rngData.Value '数据源装入数组
    lngGistCol = lngGistCol - rngData.Column + 1
    '计算依据列在数组中的位置
    lngColCount = UBound(aData, 2)
    '数据源的列数
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ReDim aRef(1 To UBound(aData))
    For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等
        If IsError(aData(i, lngGistCol)) Then
            aRef(i) = "错误值"
        ElseIf aData(i, lngGistCol) = "" Then
            strTemp = "" '判断是否整行数据为空
            For j = 1 To lngColCount
                strTemp = strTemp & aData(i, j)
            Next
            If strTemp = "" Then '如果整行为空
                aRef(i) = "整行空白"
            Else
                aRef(i) = "空白单元格"
            End If
        Else
            strKey = aData(i, lngGistCol)
            aRef(i) = strKey
        End If
    Next
    For i = lngTitleCount + 1 To UBound(aData)
        strKey = aRef(i)
        If strKey <> "整行空白" Then
            If Not d.exists(strKey) Then
            '字典中不存在关键字时则遍历建表
                d(strKey) = ""
                ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组
                k = 0
                For x = lngTitleCount + 1 To UBound(aData) '遍历数据源
                    strTemp = aRef(x)
                    If strTemp = strKey Then '如果记录符合条件，则装入结果数组
                        k = k + 1
                        For j = 1 To lngColCount
                            aResult(k, j) = aData(x, j)
                        Next
                    End If
                Next
                For Each sht In ActiveWorkbook.Worksheets '删除旧表
                    If sht.Name = strKey Then sht.Delete
                Next
                With Worksheets.Add(, Sheets(Sheets.Count))
                '新建一个工作表
                    .Name = strKey
                    .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
                    '设置单元格为文本格式
                    If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData
                    '标题行
                    .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
                    '写入数据
                    If strYesOrNo = vbYes Then '如果用户选择保留总表格式
                        rngFormat.Copy
                        .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                         '复制粘贴总表的格式
                        .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
                        '删除多余的格式单元格
                    End If
                    .Range("a1").Select
                End With
            End If
        End If
    Next
    rngData.Parent.Activate '回到总表
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    MsgBox "数据拆分完成！"
End Sub

代码2

Private Sub Worksheet_Change(ByVal Target As Range)
   ActiveWorkbook.RefreshAll
End Sub

运行结果（此处有调用第15节所用到的代码，所以运行16节代码时，一定保证代码模块有第15节所代码）

第17节批量将工作表转换为独立的工作簿

场景：将一个工作簿中许多的分表转换为独立的工作簿

原表

代码

Sub EachShtToWorkbook()
    Dim sht As Worksheet, strPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
   '选择保存工作薄的文件路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
        '读取选择的文件路径,如果用户未选取路径则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.DisplayAlerts = False
    '取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。
    Application.ScreenUpdating = False '取消屏幕刷新
    For Each sht In Worksheets '遍历工作表
        sht.Copy '复制工作表，工作表单纯复制后，会成为活动工作薄
        With ActiveWorkbook
            .SaveAs strPath & sht.Name, xlWorkbookDefault
            '保存活动工作薄到指定路径下，以当前系统默认文件格式
            .Close True '关闭工作薄并保存
        End With
    Next
    MsgBox "处理完成。", , "提醒"
    Application.ScreenUpdating = True '恢复屏幕刷新
    Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub

运行结果

选择存储位置

第18节将总表按任意列拆分成多个工作簿

是第16节和第17节的组合，先将总表按任意列拆分为各个分表，再将分表批量拆分为多个工作簿

原始表

Excel——开发工具——Visual Basic——点击插入——选择模块——复制代码，粘贴进去——将鼠标光标定位到代码语句中（确保一会运行的是该子模块代码）——点击绿色三角号（运行子过程）

Sub SplitShts()
    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range, ws As Workbook
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range, aRef, strYesOrNo As String
    Dim strKey As String, strTemp As String, strPath As String
    On Error Resume Next '忽略错误，程序继续运行
    Set d = CreateObject("scripting.dictionary")
    With Application.FileDialog(msoFileDialogFolderPicker)
    '用户选择保存工作簿的路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    '用户选择的拆分依据列
    If rngGist Is Nothing Then Exit Sub
    lngGistCol = rngGist.Column '拆分依据列的列标
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))
    '用户设置总表的标题行数
    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    strYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)
    Set rngData = rngGist.Parent.UsedRange
    '总表的数据区域
    Set rngFormat = rngGist.Parent.Cells
    '总表的单元格区域用于粘贴总表格式
    aData = rngData.Value '数据源装入数组
    lngGistCol = lngGistCol - rngData.Column + 1
    '计算依据列在数组中的位置
    lngColCount = UBound(aData, 2)
    '数据源的列数
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ReDim aRef(1 To UBound(aData))
    For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等
        If IsError(aData(i, lngGistCol)) Then
            aRef(i) = "错误值"
        ElseIf aData(i, lngGistCol) = "" Then
            strTemp = "" '判断是否整行数据为空
            For j = 1 To lngColCount
                strTemp = strTemp & aData(i, j)
            Next
            If strTemp = "" Then '如果整行为空
                aRef(i) = "整行空白"
            Else
                aRef(i) = "空白单元格"
            End If
        Else
            strKey = aData(i, lngGistCol)
            aRef(i) = strKey
        End If
    Next
    For i = lngTitleCount + 1 To UBound(aData)
        strKey = aRef(i)
        If strKey <> "整行空白" Then
            If Not d.exists(strKey) Then
            '字典中不存在关键字时则遍历建表
                d(strKey) = ""
                ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组
                k = 0
                For x = lngTitleCount + 1 To UBound(aData) '遍历数据源
                    strTemp = aRef(x)
                    If strTemp = strKey Then '如果记录符合条件，则装入结果数组
                        k = k + 1
                        For j = 1 To lngColCount
                            aResult(k, j) = aData(x, j)
                        Next
                    End If
                Next
                Set ws = Workbooks.Add
                With ws.Sheets(1)
                '新建一个工作簿
                    .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
                    '设置单元格为文本格式
                    If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData
                    '标题行
                    .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
                    '写入数据
                    If strYesOrNo = vbYes Then '如果用户选择保留总表格式
                        rngFormat.Copy
                        .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                         '复制粘贴总表的格式
                        .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
                        '删除多余的格式单元格
                    End If
                    .Range("a1").Select
                End With
                ws.SaveAs strPath & strKey, xlWorkbookDefault
                ws.Close False
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    MsgBox "数据拆分完成！"
End Sub

运行结果

首先提示，选择拆分后工作簿存储位置（这里我新建了文件夹，随意能记住自己存储就可），点击确定

然后弹出，选择拆分依据列，选择后，点击确定

接着，输入标题行数（我理解是告诉代码行数占几行，便于区别标题内容与主内容）

最终结果和第17节的运行结果一样，表格被拆分出为13个工作簿

第19节选中行或列会填充颜色

场景：如点击2012年，整行/整列都会填充颜色，便于某行和列的对照查看

双击thisworkbook，复制粘贴代码，不用运行

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = False
    Cells.Interior.ColorIndex = -4142 '取消单元格原有填充色，但不包含条件格式产生的颜色。
    Rows(Target.Row).Interior.ColorIndex = 33 '活动单元格整行填充颜色
    Columns(Target.Column).Interior.ColorIndex = 33 '活动单元格整列填充颜色
    Application.ScreenUpdating = True
End Sub

效果

第20节按指定名称批量创建工作簿

把要创建工作簿的名称写在A列，从A2单元格开始写

Sub CreateFiles()
    Dim strPath As String, strFileName As String
    Dim i As Long, r
    On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        '用户选择文件夹路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
        '如果用户为选择文件夹则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False '取消屏幕刷新
    Application.DisplayAlerts = False '取消警告提示，当有重名工作簿时直接覆盖
    r = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组r
    For i = 2 To UBound(r) '标题不要，因此从第2个元素开始遍历数组r
        With Workbooks.Add '新建工作簿
            .SaveAs strPath & r(i, 1), xlWorkbookDefault
            '以指定名称、默认文件类型保存工作簿
            .Close True '关闭工作簿
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "创建完成。"
End Sub

插入——模块——复制代码粘贴到此处——光标定位到代码语句中（确保系统一会运行的是该段代码）——点击运行子模块