vba 拆分工作簿到不同的工作簿并保留公式以及自定义重命名

vba 拆分工作簿到不同的工作簿并保留公式以及自定义重命名

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, strFileName 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)

strFileName = InputBox("请输入文件名（标题列将会在文件名中间，用 - 隔开）：")

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) = "Error Value"
    ElseIf aData(i, lngGistCol) = "" Then
        strTemp = ""
        For j = 1 To lngColCount
            strTemp = strTemp & aData(i, j)
        Next
        If strTemp = "" Then
            aRef(i) = "Entire Row Blank"
        Else
            aRef(i) = "Blank Cell"
        End If
    Else
        strKey = aData(i, lngGistCol)
        aRef(i) = strKey
    End If
Next

For i = lngTitleCount + 1 To UBound(aData)
    strKey = aRef(i)
    Debug.Print "处理第 " & i & " 行，关键字: " & strKey
    If strKey <> "Entire Row Blank" And WorksheetFunction.CountA(rngData.Rows(i)) > 0 Then
        If Not d.exists(strKey) Then
            Debug.Print "为关键字创建工作表: " & strKey
            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)
                .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

                    For Each cell In rngData
                        If cell.HasFormula Then
                            .Cells(cell.Row, cell.Column).Formula = cell.Formula
                        End If
                    Next cell
                End If
                
                ' 只保留标题行和带有依据列值的行
                .Rows("1:" & lngTitleCount).Copy
                .Rows(lngTitleCount + k + 1 & ":" & .Rows.Count).Delete

                .Range("a1").Select
            End With

            If strFileName <> "" Then
                ws.SaveAs strPath & strFileName & " - " & strKey, xlWorkbookDefault
            Else
                ws.SaveAs strPath & strKey, xlWorkbookDefault
            End If

            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