Sub SplitSheet() Dim wb As Workbook Set wb = ThisWorkbook '替换为您要操作的工作薄 Dim ws As Worksheet Set ws =

Sub SplitSheet() Dim wb As Workbook Set wb = ThisWorkbook '替换为您要操作的工作薄 Dim ws As Worksheet Set ws = wb.Sheets("Sheet1") '替换为您要拆分的工作表名称 Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '获取最后一行的行号 Dim i As Long For i = 2 To lastRow '从第二行开始循环，因为第一行是标题 Dim sheetName As String sheetName = ws.Cells(i, 1).Value '替换为您要命名的单元格 If sheetName <> "" Then '如果单元格不为空，则创建工作表并复制数据 Dim newSheet As Worksheet Set newSheet = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) newSheet.Name = sheetName ws.Range("A1:F1").Copy '复制标题行 newSheet.Range("A1:F1").PasteSpecial xlPasteAll '粘贴标题行 ws.Range("A" & i & ":F" & i).Copy '复制当前行 newSheet.Range("A2:F2").PasteSpecial xlPasteAll '粘贴当前行 End If Next i End Sub