请教一下，分表的时候能否保留固定行

chen90218

Option Explicit
Option Base 1

Sub SplitData()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim self As Worksheet
    Set self = ActiveSheet

    Dim nLastRowNum As Long
    Dim nLastColumnNum As Long

    Dim i As Long

    ' 删除其他的sheet

    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> self.Name Then
            Sheets(i).Delete
        End If
    Next i


    Application.DisplayAlerts = True
    Application.ScreenUpdating = True


    '获取全部数据范围
    nLastRowNum = Cells(Rows.Count, 1).End(xlUp).Row
    nLastColumnNum = Cells(nLastRowNum, Columns.Count).End(xlToLeft).Column


    '获取标题
    Dim titleRange As Range
    Set titleRange = Application.InputBox(prompt:="请选择标题区域：", Type:=8)

    ' 有效数据开始行
    Dim nRowValidData As Long
    nRowValidData = titleRange.Row + titleRange.Rows.Count


    ' 获取拆分列的信息,只需要列号
    Dim splitColumnRange As Range
    Set splitColumnRange = Application.InputBox(prompt:="请选择拆分的列；选择任何一个该列的单元格即可", Type:=8)
    Dim columnNumToSplit As Long
    columnNumToSplit = splitColumnRange.Column

    ' 需要拆分的值字典
    Dim splitValueDict As Object
    ' 辅助字典用来保证顺序
    Dim splitValueDictReverse As Object
    Dim indexArray() As Long

    Set splitValueDict = CreateObject("Scripting.Dictionary")
    Set splitValueDictReverse = CreateObject("Scripting.Dictionary")


    Dim cellValue As String
    Dim ws As Worksheet


    For i = nRowValidData To nLastRowNum Step 1
        cellValue = Cells(i, columnNumToSplit).Text

        '1. 创建新的sheet；
        '2. 拷贝标题信息到新的sheet
        If Not splitValueDict.Exists(cellValue) Then
            splitValueDict(cellValue) = i
            splitValueDictReverse(i) = cellValue
            Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
            ws.Name = cellValue
            self.Activate

            titleRange.Copy _
                ws.Range(ws.Cells(titleRange.Row, titleRange.Column), ws.Cells(nRowValidData - 1, titleRange.Column))

        End If

        ' 拷贝其他内容

        Range(Cells(i, 1), Cells(i, nLastColumnNum + 1)).Copy _
            GetLastPasteRangeBySheetName(cellValue, nLastColumnNum + 1)


    Next i


End Sub



Public Function GetLastPasteRangeBySheetName(ByRef SheetName As String, columnNum As Long) As Variant
    Dim wks As Worksheet
    Dim nLastRowNum As Long

    Set wks = ActiveWorkbook.Worksheets(SheetName)
    nLastRowNum = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row

    Set GetLastPasteRangeBySheetName = wks.Range(wks.Cells(nLastRowNum + 1, 1), wks.Cells(nLastRowNum + 1, columnNum))

End Function