VBA常用案例【拿来吧你2】

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

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

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) '数据装入数组

        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

取消合并单元格

Sub UnMergeRange2() '取消合并单元格

    Dim MaxRow As Integer ' Dim Rng As Range

    Dim x%, y%, m%, n%, i%

    Dim Rng2 As Range

    On Error Resume Next

    Set rng = Application.InputBox('请选择需要取消合并单元格的区域：', '区域选择', , , , , , 8)

    For x = 1 To rng.Rows.Count

        For y = 1 To rng.Columns.Count

            Set Rng2 = rng.Cells(x, y)

            i = Rng2.MergeArea.Count

            If i > 1 Then

                m = Rng2.MergeArea.Rows.Count

                n = Rng2.MergeArea.Columns.Count

                Rng2.UnMerge '取消合并单元格

                Rng2.Resize(m, n).Value = Rng2.Value

            End If

        Next

    Next

End Sub

END