Excel VBA常用代码

YAR · 发表于 2023-1-26 19:14:30

011.汇总分表成总表（保留分表格式）

Sub CollectDataFromShtFormat()
Dim sht As Worksheet, rng As Range, k As Long, nTitleCount As Long
On Error Resume Next
nTitleCount = Val(InputBox("请输入标题的行数", "提醒", 1))
If nTitleCount < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
Application.ScreenUpdating = False
Cells.ClearContents '清空当前表数据
For Each sht In Worksheets '遍历工作表
      If sht.Name <> ActiveSheet.Name Then
      '如果工作表名称不等于当前表名则进行汇总动作……
         Set rng = sht.UsedRange
         k = k + 1 '累计K值
         If k = 1 Then '如果是首个表格，则K为1，则把标题行一起复制到汇总表
            sht.Cells.Copy: Range("a1").PasteSpecial Paste:=xlPasteFormats '只粘贴格式
            rng.Copy: Range("a1").PasteSpecial Paste:=xlPasteValues '只粘贴数值
         Else '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
            rng.Offset(nTitleCount).Copy
            With Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
                  .PasteSpecial Paste:=xlPasteFormats '粘贴格式
                  .PasteSpecial Paste:=xlPasteValues '粘贴数值
            End With
         End If
      End If
Next
Range("a1").Activate
Application.ScreenUpdating = True '恢复屏幕刷新
MsgBox "汇总OK，一共汇总了：" & k & "张工作表"
End Sub

YAR · 发表于 2023-1-26 19:18:18

012.工作表排序

Sub GetShtName()
Dim k As Long, sht As Worksheet
Application.ScreenUpdating = False
With Columns(1)
      .ClearContents '清空A列原有数据
      .NumberFormat = "@" '设置单元格格式为文本
End With
Cells(1, 1) = "目录"
k = 1
For Each sht In ThisWorkbook.Worksheets '遍历工作表
      If sht.Name <> ActiveSheet.Name Then '如果sht不等于当前工作表名称
         k = k + 1 '累加工作表个数
         Cells(k, 1) = sht.Name '工作表名称写入A列
      End If
Next
Application.ScreenUpdating = True
End Sub

YAR · 发表于 2023-1-26 19:24:12

013.批量工作表加密

Sub ProtectSht()
Dim strAds As String, sht As Worksheet
Dim strKey As String, strTemp As String
Dim rng As Range, strMsg As String
Dim strNoShtName As String, strYesShtName As String
On Error Resume Next
strAds = InputBox("请输入单元格保存范围，例如A1:B10." & vbCr _
                              & "可以设置不连续单元格，中间请以逗号分隔。比如A1:B10,D2:D8" & vbCr _
                              & "如果需要全表保护，可以直接确定。", Default:="全表保护")
If StrPtr(strAds) = False Then Exit Sub
If strAds = "全表保护" Then strAds = Cells.Address
Set rng = Range(strAds) '测试输入的单元格区域是否有效
If Err Then MsgBox "你输入的单元格区域地址不是正确的格式，请重新操作。": Exit Sub
strKey = InputBox("请输入保护密码。") '第一次输入密码
If StrPtr(strKey) = False Then Exit Sub
strTemp = InputBox("请再次输入保护密码。") '第二次输入密码
If StrPtr(strKey) = False Then Exit Sub
If strKey <> strTemp Then MsgBox "你两次输入的密码不一致，系统退出，请重新操作。": Exit Sub
For Each sht In Worksheets '遍历工作表加密保护
      With sht
         If .ProtectContents = False Then '如果工作表未保护
            .Cells.Locked = False '全部单元格区域取消锁定
            .Range(strAds).Locked = True '需要保护的区域锁定
            .Protect strKey, True, True, True '保护工作表，只允许编辑非锁定区域
            strYesShtName = strYesShtName & "," & .Name '保护成功的工作表名称
         Else
            strNoShtName = strNoShtName & "," & .Name '自身已有保护功能的工作表
         End If
      End With
Next
If strYesShtName <> "" Then strMsg = "工作表：" & Mid(strYesShtName, 2) & "的" & strAds & "区域保护完成"
If strNoShtName <> "" Then strMsg = strMsg & vbCrLf & "以下工作表自身已有保护，无法再次保护：" & Mid(strNoShtName, 2)
MsgBox (strMsg)
End Sub

YAR · 发表于 2023-1-26 19:26:41

014.批量工作表破密

Sub UnProtct()
MsgBox "**提示：当要求输入密码时请点击取消！”"
Application.DisplayAlerts = False
On Error Resume Next
Dim sht As Worksheet
For Each sht In Worksheets
      With sht
         .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
         .Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
         .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False, AllowFiltering:=True, AllowUsingPivotTables:=True
         .Protect DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
         .Unprotect
      End With
Next
MsgBox "ok"
End Sub

YAR · 发表于 2023-1-26 19:29:38

015.按任意列拆分多个表

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

YAR · 发表于 2023-1-26 19:35:32

016.按任意列拆分方法二

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

YAR · 发表于 2023-1-26 19:37:02

017.批量将工作表转换为独立的工作簿

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

YAR · 发表于 2023-1-26 19:38:13

018.将总表按任意列拆分成多个工作簿

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

YAR · 发表于 2023-1-26 19:39:29

019.选中行或列会填充颜色

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

YAR · 发表于 2023-1-26 19:40:43

020.按指定名称批量创建工作簿

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

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

[分享] Excel VBA常用代码

浏览过的版块