--Sub 批量修改批注框背景色()

Dim rng As Range

On Error Resume Next '防错'

For Each rng In Range([a1], Cells(Rows.Count, 1).End(xlUp))

'遍历A列所有非空单元格'

Debug.Print rng.Comment.Text '导出批注文字'

If Err=0 Then '如果没有错误 - 表示有批注'

rng.Comment.Visible=True '让批注可见 - 批注只能在可见状态下编辑设置'

rng.Comment.Shape.Fill.ForeColor.SchemeColor=10 '指定 批注背景颜色'

rng.Comment.Visible=False '恢复隐藏属性'

End If

Err.Clear '清楚错误'

Next

End Sub

--Sub 批量修改批注框背景色() '通过改变循环对象提速 - 批注少于已使用单元格数量'

Dim com As Comment

For Each com In ActiveSheet.Comments '遍历所有批注'

If Not Intersect(com.Parent, [a:a]) is Nothing Then

com.Visible=True '批注可见'

com.Shape.Fill.ForeColor.SchemeColor=10 '指定 批注背景色'

com.Visible=False '隐藏批注'

End If

Next

End Sub

--Sub 合并所有工作表()

'创建工作表 "总表"'

With Sheets.Add(after:=Sheets(Sheets.Count))

.Name="总表"

End With

'合并四个班级的成绩'

Sheets("一班").[a1:d13].Copy Sheets("总表").Cells(Rows.Count,1).End(xlUp)

Sheets("二班").[a1:d13].Copy Sheets("总表").Cells(Rows.Count,1).End(xlUp).Offset(1,0)

Sheets("三班").[a1:d13].Copy Sheets("总表").Cells(Rows.Count,1).End(xlUp).Offset(1,0)

Sheets("四班").[a1:d13].Copy Sheets("总表").Cells(Rows.Count,1).End(xlUp).Offset(1,0)

ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\已合并.xlsm", xlOpenXMLWorkbookMacroEnabled

End Sub

--Sub 合并所有工作表()

Dim i As Integer, sht As Worksheet, bt As Integer '声明变量'

'如果当前工作薄已经是 已合并 则退出程序'

If ActiveWorkbook.Name="已合并.xlsm" Then Exit Sub

On Error Resume Next

'手法1 创建工作表中判断是否有同名工作表，避免出错'

Set sht=Sheets("总表") '将 总表 工作表赋予变量'

If err<>0 Then '如果出错 表示不存在 总表 工作表'

With Sheets.Add(after:=Sheets(Sheets.Count)) '新建 工作表 命名为 总表'

.Name="总表"

End With

Else

Sheets("总表").Move Sheets(Sheets.Count) '将 总表 工作表移至最后'

Sheets("总表").Cells.Clear '手法2 如果已有 总表，清除其原有数据'

End If

'手法3 让用户选择标题行数'

bt=Application.InputBox("标题行数为","请指定标题行数",1,,,,,1)

If bt>0 And bt< 10 Then '如果标题行数在1到10之间，则执行复制'

Sheets(1).Row("1:" & bt).Copy Sheets("总表").[a1] '先复制标题'

'手法4 利用Sheets.Count计算待汇总工作表数量'

For i=1 To Sheets.Count-1 '循环 总表 以外的所有工作表'

'手法5 如果非空表则复制 否则跳过'

If Not IsEmpty(Sheets(i).UsedRange) Then '如果工作表为 非空'

Intersect(Sheets(i).UsedRange,Sheets(i).UsedRange.Offset(bt,0)).Copy Sheets("总表").Cells(Rows.Count,1).End(xlUp).Offset(1,0)

End If

Next i

'手法6 判断当前工作薄是否保存过。如果没有则让用户选择保存路径，否则另存到当前文件相同路径下'

If Len(Dir(ActiveWorkbook.Path,vbDirectory))<2 Then '如果工作薄没有保存'

With Application.FileDialog(msoFileDialogFolderPicker) '显示打开文件夹对话框'

If .Show=-1 Then '如果选择了文件夹 则将当前工作薄保存到该文件夹'

ActiveWorkbook.SaveAs .SelectedItems(1) & IIf(Right$(.SelectedItem(1),1)="","","") & "\已合并.xlsm",xlOpenXMLWorkbookMacroEnabled

End If

End With

Else '否则 当前工作薄另存到当前工作薄相同路径下，工作薄名为 已合并.xlsm'

ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\已合并.xlsm",xlOpenXMLWorkbookMacroEnabled

End If

End If

End Sub

--对于行列数不同引起的兼容性问题，可以利用动态引用的方式处理。通常采用[a65536].end(xlUp)和[a1048576].end(xlUp)引用最后一个非空行。然而这两种方式都不能兼容多个版本，较好的方式如下:

* Cells(Rows.Count,1) 第一列最后一个非空单元格

* Cells(1,Columns.Count) 第一行最后一个非空单元格