vba拆分表格和设置保护工作表

hibari18018

请教大神，当前表内的vba用于拆分表格，但第一次拆分后如果把拆分出来的子表删除，再次拆分表头就只有一行，需求是再次拆分后，子表仍保留三行表头

另外新增一个需求：表内已经设置了单元格锁定和未锁定，希望拆分完表格后，可以设置密码保护工作表，设置不能编辑锁定的单元格，但可以编辑未锁定的单元格

hibari18018

目前用的拆分代码是这个
Sub 拆分数据至表内()
    Dim sht As Worksheet
    Dim k, i, j As Integer
    Dim irow As Integer
    Dim l As Integer
    Dim str As String
   
    str = ActiveSheet.Name
    l = InputBox("请输入你要按哪列分（阿拉伯数字）")
    irow = Sheets(str).Range("A65536").End(xlUp).Row
   
    ' 拆分表
    For i = 4 To irow
        k = 0
        For Each sht In Sheets
            If sht.Name = Sheets(str).Cells(i, l) Then
                k = 1
            End If
        Next
        
        If k = 0 Then
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = Sheets(str).Cells(i, l)
        End If
        
        ' 复制数据、格式和公式
        Sheets(str).Range("A" & i & ":IV" & i).Copy
        Sheets(Sheets(str).Cells(i, l).Value).Range("A1").PasteSpecial xlPasteAll
    Next
   
    ' 清除剪贴板内容
    Application.CutCopyMode = False
   
    ' 清除筛选条件以确保所有数据都可见
    For j = 3 To Sheets.Count
        Sheets(str).Range("A1:IV" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
        Sheets(str).Range("A1:IV" & irow).Copy
        Sheets(j).Range("A1").PasteSpecial xlPasteAll
        ' 清除剪贴板内容
        Application.CutCopyMode = False
    Next
   
    Sheets(str).Range("A1:IV" & irow).AutoFilter
    Sheets(str).Select
    MsgBox "已处理完毕"
End Sub

hibari18018

目前excel中用的代码如下：

Sub 拆分数据至表内()
    Dim sht As Worksheet
    Dim k, i, j As Integer
    Dim irow As Integer
    Dim l As Integer
    Dim str As String
   
    str = ActiveSheet.Name
    l = InputBox("请输入你要按哪列分（阿拉伯数字）")
    irow = Sheets(str).Range("A65536").End(xlUp).Row
   
    ' 拆分表
    For i = 4 To irow
        k = 0
        For Each sht In Sheets
            If sht.Name = Sheets(str).Cells(i, l) Then
                k = 1
            End If
        Next
        
        If k = 0 Then
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = Sheets(str).Cells(i, l)
        End If
        
        ' 复制数据、格式和公式
        Sheets(str).Range("A" & i & ":IV" & i).Copy
        Sheets(Sheets(str).Cells(i, l).Value).Range("A1").PasteSpecial xlPasteAll
    Next
   
    ' 清除剪贴板内容
    Application.CutCopyMode = False
   
    ' 清除筛选条件以确保所有数据都可见
    For j = 3 To Sheets.Count
        Sheets(str).Range("A1:IV" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
        Sheets(str).Range("A1:IV" & irow).Copy
        Sheets(j).Range("A1").PasteSpecial xlPasteAll
        ' 清除剪贴板内容
        Application.CutCopyMode = False
    Next
   
    Sheets(str).Range("A1:IV" & irow).AutoFilter
    Sheets(str).Select
    MsgBox "已处理完毕"
End Sub

zpy2

hibari18018 发表于 2023-11-2 12:23
目前excel中用的代码如下：

Sub 拆分数据至表内()

望拆分完表格后，可以设置密码保护工作表，设置不能编辑锁定的单元格，但可以编辑未锁定的单元格

这个会增加很多代码，一个是读取原来的锁定，要遍历，速度也会影响

hibari18018

zpy2 发表于 2023-11-2 17:45
望拆分完表格后，可以设置密码保护工作表，设置不能编辑锁定的单元格，但可以编辑未锁定的单元格

这个 ...

那能否设定某几列未锁定，比如每个sheet的D列和F列设为未锁定，其他单元格锁定，保护工作表保护锁定的单元格？