如何修改Excel VBA拆分工作表宏：添加名称前缀与复制列宽

我帮你调整了宏代码，搞定了给新工作表加前缀和复制列宽这两个问题，下面是修改后的完整代码：

Sub Copy_Data()
    Dim r As Range, LastRow As Long, ws As Worksheet
    Dim LastRow1 As Long, MyColumn As String
    Dim src As Worksheet
    Dim Prefix As String ' 新增前缀变量
    
    MyColumn = "C"
    Prefix = "分类" ' 这里改成你想要的前缀文本
    Set src = Sheets("Sheet1")
    
    LastRow = src.Cells(src.Rows.Count, MyColumn).End(xlUp).Row
    For Each r In src.Range(MyColumn & "4:" & MyColumn & LastRow)
        On Error Resume Next
        Set ws = Sheets(Prefix & " " & CStr(r.Value)) ' 检查带前缀的工作表是否存在
        On Error GoTo 0
        
        If ws Is Nothing Then
            ' 创建带前缀的新工作表
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Prefix & " " & CStr(r.Value)
            ' 复制表头
            src.Rows("1:3").Copy ActiveSheet.Range("A1")
            ' 复制原工作表的列宽到新表
            src.UsedRange.Columns.Copy
            ActiveSheet.Columns.PasteSpecial xlPasteColumnWidths
            Application.CutCopyMode = False ' 清除复制状态
            
            ' 复制当前行数据
            LastRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, MyColumn).End(xlUp).Row
            src.Rows(r.Row).Copy ActiveSheet.Cells(LastRow1 + 1, 1)
            Set ws = Nothing
        Else
            ' 复制数据到已存在的工作表
            LastRow1 = ws.Cells(ws.Rows.Count, MyColumn).End(xlUp).Row
            src.Rows(r.Row).Copy ws.Cells(LastRow1 + 1, 1)
            Set ws = Nothing
        End If
    Next r
End Sub

关键修改说明： #

• 添加工作表名称前缀：
  新增了Prefix变量，你可以把Prefix = "分类"里的"分类"改成任何你需要的文本（比如"部门"、"项目"）。创建新工作表和检查工作表是否存在时，都用Prefix & " " & CStr(r.Value)来组合名称，确保新表名称是“前缀 数值”的格式。

• 复制列宽：
  在复制表头之后，加入了列宽复制的代码：先复制原表已使用区域的列属性，再通过PasteSpecial xlPasteColumnWidths专门粘贴列宽，最后用Application.CutCopyMode = False清除复制状态，避免后续操作受影响。这样新工作表的列宽就和原表完全一致了。

另外我还优化了一处小细节：原代码中Cells.Rows.Count没有指定工作表，可能会引发错误，修改为src.Rows.Count和ActiveSheet.Rows.Count，确保引用的是正确工作表的行数。

内容的提问来源于stack exchange，提问作者Somebody