Excel VBA问题：按B列名称创建工作表并复制对应数据失败

原代码存在的问题 #

• 数据覆盖问题：每次固定粘贴到目标表的A1单元格，后续数据会覆盖之前的内容，无法实现行下移。
• 无法创建后续工作表：循环中未重置sht变量，处理第一个名称后，sht保留着该工作表的引用，导致后续判断新名称是否存在时出错，无法创建新工作表。

修正后的代码 #

Sub CreateSheetsForNames()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim sht As Worksheet
    Dim lastRow As Long
    
    Set ws = ThisWorkbook.Sheets("SM")
    Set rng = ws.Range("B2", ws.Range("B" & Rows.Count).End(xlUp))
    
    For Each cell In rng
        ' 每次循环重置sht，避免旧引用干扰判断
        Set sht = Nothing
        
        If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
            On Error Resume Next
            Set sht = ThisWorkbook.Sheets(cell.Value)
            On Error GoTo 0
            
            ' 工作表不存在则创建
            If sht Is Nothing Then
                Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                sht.Name = cell.Value
                ' 复制表头到新表（按需保留）
                ws.Range("A1:H1").Copy sht.Range("A1")
            End If
            
            ' 找到目标表的最后一行，追加数据
            lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
            ws.Range("A" & cell.Row & ":H" & cell.Row).Copy sht.Range("A" & lastRow)
        End If
    Next cell
End Sub

关键修改说明 #

1. 重置sht变量：在每次循环开始时执行Set sht = Nothing，确保每次判断工作表是否存在时，都是基于当前单元格的名称，不会被之前的工作表引用干扰。
2. 动态获取粘贴位置：通过lastRow计算目标工作表A列最后一行的下一行，保证数据依次追加，不会覆盖原有内容。
3. 可选表头复制：新创建工作表时自动复制主表的表头，让每个人员的工作表结构更完整（不需要可删除该行代码）。

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