VBAEXCEL多表合并批注整理
源文件，下载后可直接体验👈
相关学习链接推荐：
Office Visual Basic for Applications (VBA) 参考 | Microsoft Docs
Excel VBA工作应用经典十例_哔哩哔哩_bilibili
以上是相关学习教程，仅供参考！！！
学习过程中的整理的相关代码与实例都在下文了！！！
1. 基础代码整理
2. 多表合并代码
多表合并表头相同的情况下，实现多表合并，具体细节根据注释需要自己去完善代码
Public Sub ll()
Dim sa As Worksheet
Dim ab As Integer
Dim sc As Range
Sheet4.Activate
For Each sa In Worksheets
If sa.Name <> ActiveSheet.Name Then
' 下边提取活动表,也就是sheet4从A65536及顶端的数据,Offset是返回除指定区域以外的区域
' 需要注意这里的Range("A65536")需要尽可能设置大一点，不然会造成多表内容覆盖
' 举个例子，有5张row为10表，如果这里的A65536设置为10，那么sheet会被这10张表反复替代，最后运行的是哪张表，sheet4就保存的是哪张表
Set sc = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
' 获取行数为被复制表的（非标题行）
sb = sa.Range("a1").CurrentRegion.Rows.Count - 1
' 表的拷贝
sa.Range("a2").Resize(sb, 5).Copy sc
End If
Next
End Sub
挂上上述代码中的相关链接，方便查看，里边有相关函数的Demo，一看就懂：
返回一个 Range 对象，它表示包含源范围的区域末尾的单元格。 相当于按 End+向上键、End+向下键、End+向左键或 End+向右键。 此为只读 Range 对象。
返回一个 Range 对象，它表示指定区域以外的一个区域。
返回一个 Range 对象，它表示一个单元格或单元格区域。
' 附上完整版代码
Public Sub ll()
Dim sa As Worksheet
Dim ab As Integer
Dim sc As Range
Dim NumOfSheet As Integer
Dim WSN As String
NumOfSheet = 0
Sheet6.Activate
For Each sa In Worksheets
If sa.Name <> ActiveSheet.Name Then
NumOfSheet = NumOfSheet + 1
Set sc = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
sb = sa.Range("a1").CurrentRegion.Rows.Count - 1
sa.Range("a2").Resize(sb, 5).Copy sc
WSN = WSN & Chr(13) & sa.Name
End If
Next
MsgBox "共合并了" & Num & "个工作表。如下：" & Chr(13) & WSN, vbInformation, "提示"
End Sub
实例①: 合并多个excel
合并多个excel中多个sheet，每个sheet单独合并
' 合并多个excel中多个sheet，每个sheet单独合并
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim WbAs Workbook, WbNAs String
Dim GAs Long
Dim NumAs Long
Dim BOXAs String
flag = 0
Application.ScreenUpdating =False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath &"\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <>""
If MyName <> AWbNameThen
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
For G = 1To Wb.Sheets.Count
If flag = 0Then
Sheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Wb.Sheets(G).Name
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row, 1)
.UsedRange.Rows.AutoFit
.UsedRange.Columns.AutoFit
End With
Else
With Workbooks(1).Worksheets(G + 3)
' MsgBox .Name & "--" & Wb.Sheets(G).Name
If G = 2Then
Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 2, 1)
Else
Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
End If
.UsedRange.Rows.AutoFit
.UsedRange.Columns.AutoFit
End With
End If
Next
'flag 为0时候为第一个打开的excel，此时产生列，sheet名
flag = 1
WbN = WbN & Chr(13) & Wb.Name
Wb.CloseFalse
' End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating =True
MsgBox"共合并了" & Num &"个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation,"提示"
End Sub
实例②: 设置单元格有效性
Sub dataValidity()
Dim oWK As Worksheet
Dim oRng As Range
Set oWK = Excel.ActiveSheet
Set oRng = oWK.Range("a1:a100")
With oRng.Validation
'先删除之前的数据有效性
.Delete
'再添加新的数据有效性下拉列表
.Add Type:=xlValidateList, Formula1:="红,黄,蓝,绿"
End With
End Sub
3. 提取批注
提取批注
' 提取批注
Sub AllCommentsList()
'声明变量
Dim wb As Workbook
Dim ws As Worksheet
Dim cmt As Comment
Dim lngCmtCount As Long
'赋初始值,代表第2行
lngCmtCount = 2
'关闭屏幕刷新
Application.ScreenUpdating = False
'新建带有1个工作表的工作簿
Set wb = Workbooks.Add(xlWorksheet)
'在新建的工作簿中输入标题行
With wb.Sheets(1)
.Range("A1") = "作者"
.Range("B1") = "工作簿"
.Range("C1") = "工作表"
.Range("D1") = "单元格"
Range("E1") = "批注"
End With
'遍历代码所在的工作簿中的工作表
For Each ws In ThisWorkbook.Worksheets
'遍历工作表中的批注
For Each cmt In ws.Comments
'将批注信息输入新工作簿中
With wb.Sheets(1)
'批注作者
.Cells(lngCmtCount, 1) = cmt.author
'批注所在工作簿名
.Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name
'批注所在工作表名
.Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name
'批注所在单元格地址
.Cells(lngCmtCount, 4) = cmt.Parent.Address
'批注内容,调用子过程来清理批注内容
.Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)
End With
'增加行计数
lngCmtCount = lngCmtCount + 1
Next cmt
Next ws
'设置单元格区域不换行
wb.Sheets(1).UsedRange.WrapText = False
'关闭屏幕刷新
Application.ScreenUpdating = True
'释放对象变量
Set ws = Nothing
Set wb = Nothing
End Sub
'清理批注内容
Private Function CleanComment(author As String, cmt As String) As String
Dim tmp As String
'去掉批注作者
tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")
'去掉批注中多余的空格
tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")
'返回清理后的批注内容
CleanComment = tmp
End Function
N. 基础代码整理
1）刷屏
' 执行程序前设置为False
Application.ScreenUpdatin = False ' 关闭刷屏
' 执行后设置为True
Application.ScreenUpdatin = True
个人撰写代码-提取批注
' 定义全局变量存放文件名
Public Sub globalFun()
Public arr() As String
Public fileNum As Integer
End Sub
'运行
Public Sub CommandButtonRun_Click()
Dim l As Long
Dim files As String
fileNum = 0
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True '单选择
.Filters.Clear '清除文件过滤器
.Filters.Add "Excel Files", "*.xlsx;*.xlsm;*.xls;*.csv"
.Filters.Add "All Files", "*.*" '设置两个文件过滤器
If .Show = -1 Then
ReDim arr(1 To .SelectedItems.Count) As String
For l = 1 To .SelectedItems.Count
fileNum = fileNum + 1
files = files & Chr(13) & .SelectedItems(l) & Chr(10)
arr(l) = .SelectedItems(l)
Next
Else
MsgBox "未选择文件", vbCritical, "警告"
GoTo runEnd
End If
MsgBox "您选择的文件是：" & files, vbOKOnly + vbInformation, "提示"
ThisWorkbook.Sheets("Sheet1").Range("G11") = files
Call HighLightPath(11)
End With
'creatFile
Call creatSheet(arr(), fileNum)
runEnd:
End Sub
Public Sub HighLightPath(row As Integer)
Dim s%
Application.ScreenUpdating = False
' MsgBox Len(Cells(4, 7)), vbInformation, "提示"
For j = 1 To Len(Cells(row, 7))
If Mid(Cells(row, 7), j, 1) = "\" Then
s = j
With Cells(row, 7).Characters(s, 1)
.Font.ColorIndex = 3
.Font.Bold = True
.Font.Size = 9
End With
End If
Next j
Application.ScreenUpdating = True
End Sub
Private Sub creatSheet(ByRef fileArr() As String, ByVal fileNum As Integer)
Dim ws As Worksheet
Dim FileName As String
Dim wb As Workbook
Dim index As Integer
Application.ScreenUpdating = False
'step1---------------------------------------------------
'创建新工作簿
If OptionButtonNewBook.Value Then
Set wb = Workbooks.Add
Set ws = wb.Sheets("Sheet1")
'判断是否已有该文件
If FileFolderExists(FileName) = True Then
For i = 1 To 100
FileName = ThisWorkbook.Path & "\" & "批注(" & i & ")-" & ThisWorkbook.Name
If FileFolderExists(FileName) = False Then
Call initSheet(ws)
MsgBox "文件创建路径为" + Chr(13) + FileName, vbOKOnly + vbInformation, "提示"
wb.SaveAs FileName:=FileName
Exit For
End If
Next i
End If
'当前工作簿
Else
FileName = "当前工作簿（" & ThisWorkbook.Name & ")"
Set ws = Worksheets.Add
MsgBox "新表已创建", vbOKOnly + vbInformation, "提示"
Call initSheet(ws)
End If
Call HighLightPath(14)
'step2---------------------------------------------------
'写入批注
'遍历代码所在的工作簿中的工作表
Dim tws As Worksheet
Dim twb As Workbook
Dim cmt As Comment
Dim lngCmtCount As Long
'赋初始值,代表第4行
lngCmtCount = 4
'赋初始值,序号
index = 1
For i = 1 To fileNum
'新建带有1个工作表的工作簿
Set twb = Workbooks.Open(fileArr(i))
For Each tws In twb.Worksheets
'遍历工作表中的批注
For Each cmt In tws.Comments
'将批注信息输入新工作簿中
With ws
'批注作者
.Cells(lngCmtCount, 1) = index
index = index + 1
'批注所在工作簿名
.Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name
'批注所在工作表名
.Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name
'批注所在单元格地址
.Cells(lngCmtCount, 4) = cmt.Parent.Address
'批注内容,调用子过程来清理批注内容
.Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)
End With
'增加行计数
lngCmtCount = lngCmtCount + 1
Next cmt
Next tws
Next
wb.SaveAs FileName:=FileName
'---------------------------------------------------
MyEnd:
ThisWorkbook.Sheets("Sheet1").Range("G14") = FileName
Application.ScreenUpdating = True
End Sub
'判断文件是否存在
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
'清理批注内容
Private Function CleanComment(author As String, cmt As String) As String
Dim tmp As String
'去掉批注作者
tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")
'去掉批注中多余的空格
tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")
'返回清理后的批注内容
CleanComment = tmp
End Function
Public Sub writeMemo(ByVal ws As Worksheet, ByRef fileArr() As String, ByVal fileNum As Integer)
'写入批注
For i = 1 To fileNum
'新建带有1个工作表的工作簿
Set wb = Workbooks.Open: FileName = fileArr(i)
'TODO
'遍历代码所在的工作簿中的工作表
For Each ws In wb.Worksheets
'遍历工作表中的批注
For Each cmt In ws.Comments
'将批注信息输入新工作簿中
With ws
'批注作者
.Cells(lngCmtCount, 1) = index
index = index + 1
'批注所在工作簿名
.Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name
'批注所在工作表名
.Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name
'批注所在单元格地址
.Cells(lngCmtCount, 4) = cmt.Parent.Address
'批注内容,调用子过程来清理批注内容
.Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)
End With
'增加行计数
lngCmtCount = lngCmtCount + 1
Next cmt
Next ws
Next
End Sub
Public Function initSheet(ByRef ws As Worksheet)
'设置表头格式
With ws
.Range("A3") = "#"
.Range("B3") = "文件名"
.Range("C3") = "表格"
.Range("D3") = "单元格"
.Range("E3") = "批注内容"
.Range("F3") = "严重程度"
' --------
.Range("G3") = "文档审核人"
.Range("H3") = "审核时间"
.Range("I3") = "发现时机"
.Range("J3") = "修改方案"
.Range("K3") = "评审确认"
.Range("L3") = "计划修改时间"
.Range("M3") = "修改人"
.Range("N3") = "验证人"
.Range("O3") = "缺陷状态"
.Range("P3") = "验证关闭时间"
.Range("Q3") = "备注"
With .Rows("3:3").Select
Selection.Font.Size = 11
Selection.Font.Bold = True
Selection.Font.Name = "宋体"
Selection.HorizontalAlignment = xlHAlignCenter
Selection.WrapText = False
End With
'设置A3I3背景颜色
.Range("A3:I3").Select
With Selection.Interior
.Pattern = xlPatternSolid
.Color = 65535
.TintAndShade = 0
.PatternColorIndex = -4105
End With
'设置J3:M3背景颜色
.Range("J3:M3").Select
With Selection.Interior
.Pattern = xlPatternSolid
.Color = 192
.TintAndShade = 0
.PatternColorIndex = -4105
End With
'设置N3:P3背景颜色
.Range("N3:P3").Select
With Selection.Interior
.Pattern = xlPatternSolid
.Color = 5287936
.TintAndShade = 0
.PatternColorIndex = -4105
End With
'设置Q3背景颜色
.Range("Q3").Select
With Selection.Interior
.Pattern = xlPatternSolid
.ThemeColor = 1
.TintAndShade = -0.5
.PatternColorIndex = -4105
End With
'设置边框
With .Range("A3:Q1000").Select
With Selection.Borders(xlEdgeLeft)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeTop)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeBottom)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Borders(xlEdgeLeft).ColorIndex = xlColorIndexAutomatic
Selection.Borders(xlEdgeTop).ColorIndex = xlColorIndexAutomatic
Selection.Borders(xlEdgeBottom).ColorIndex = xlColorIndexAutomatic
Selection.Borders(xlEdgeRight).ColorIndex = xlColorIndexAutomatic
Selection.Borders(xlInsideVertical).ColorIndex = xlColorIndexAutomatic
Selection.Borders(xlInsideHorizontal).ColorIndex = xlColorIndexAutomatic
End With
'设置自动列宽
With .Range("A3:Q3").Select
Selection.AutoFit
End With
'添加批注
With .Range("E3").Select
Selection.AddComment Text:="批注内容较多时，高亮显示"
End With
'设置缺陷描述和修改方案宽度
With .Columns("E:E").Select
Selection.ColumnWidth = 28.5
End With
With .Columns("J:J").Select
Selection.ColumnWidth = 28.5
End With
'设置大标题
With .Range("A1:Q2").Select
With Selection
.Merge Across:=False
.HorizontalAlignment = xlHAlignCenter
End With
End With
With .Range("A1")
.Formula = "缺陷汇总跟踪表"
With .Characters.Font
.Name = "宋体"
.Bold = True
.Italic = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.ThemeColor = 2
.TintAndShade = 0
.Underline = xlUnderlineStyleNone
.Size = 20
End With
End With
'冻结窗格
.Range("R4").Activate
ActiveWindow.FreezePanes = True
'设置自动换行
With .Range("A3:Q3").Select
Selection.WrapText = True
End With
'设置表头高度
.Rows("2:2").RowHeight = 33
.Rows("3:3").RowHeight = 32
'设置批注内容长度大于20的背景色
With .Range("E4:E1048576").Select
Selection.FormatConditions.Add Type:=xlExpression, Operator:=-1, Formula1:="=LEN(E4)>20", Formula2:=""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Interior.Pattern = xlPatternSolid
Selection.FormatConditions(1).Interior.PatternColorIndex = -4105
Selection.FormatConditions(1).Interior.PatternTintAndShade = 0
Selection.FormatConditions(1).Interior.ThemeColor = 10
Selection.FormatConditions(1).Interior.TintAndShade = 0.6
Selection.FormatConditions(1).StopIfTrue = False
End With
'设置表头筛选
With .Rows("3:3").Select
Selection.AutoFilter
ActiveWorkbook.Names.Add Name:="Sheet1!_FilterDatabase", RefersTo:="=Sheet1!$A$3:$Q$3", Visible:=False
Selection.Select
End With
With .Columns("A:A").Select
Selection.HorizontalAlignment = xlHAlignCenter
Selection.VerticalAlignment = xlVAlignCenter
End With
'设置K\F列条件格式
Call SetFormat(ws)
End With
'设置单元格区域不换行
ws.UsedRange.WrapText = True
End Function
Public Sub SetFormat(ByRef ws As Worksheet)
With ws.Range("F4:F1048576")
.FormatConditions.Add Type:=xlTextString, String:="严重", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.Color = 192
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlTextString, String:="一般", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.Color = 49407
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlTextString, String:="轻微", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.ThemeColor = 10
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
End With
With ws.Range("K4:K1048576")
.FormatConditions.Add Type:=xlTextString, String:="接受", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.ThemeColor = 10
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlTextString, String:="拒绝", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.Color = 192
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlTextString, String:="重复", TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Pattern = xlPatternSolid
.FormatConditions(1).Interior.PatternColorIndex = -4105
.FormatConditions(1).Interior.PatternTintAndShade = 0
.FormatConditions(1).Interior.Color = 49407
.FormatConditions(1).Interior.TintAndShade = 0
.FormatConditions(1).StopIfTrue = False
End With
End Sub
1308
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
