如何修改VBA脚本按ItemCode创建独立工作表并自动调整列宽

需求要点 #

• 给每个唯一的ItemCode单独创建工作表，表内仅保留该ItemCode对应的数据
• 新工作表中，除首行数据外，其余行的ItemCode和ItemDescr列留空
• 自动适配ItemDescr列的宽度，无需手动拖拽调整

修改后的VBA代码 #

Sub CreateTabsFromUniqueItemCode()
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Dim lastRow As Long, i As Long, newRow As Long
    Dim uniqueCodes As Collection
    Dim currentCode As String, wsDest As Worksheet
    
    ' 收集所有唯一的ItemCode
    Set uniqueCodes = New Collection
    On Error Resume Next
    For i = 2 To wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        currentCode = wsSource.Cells(i, "A").Value
        uniqueCodes.Add currentCode, Key:=CStr(currentCode)
    Next i
    On Error GoTo 0
    
    ' 遍历每个唯一ItemCode处理
    For Each currentCode In uniqueCodes
        ' 检查目标工作表是否已存在
        Set wsDest = Nothing
        On Error Resume Next
        Set wsDest = ThisWorkbook.Sheets(currentCode)
        On Error GoTo 0
        
        ' 不存在则新建工作表并写入表头
        If wsDest Is Nothing Then
            Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSource)
            wsDest.Name = currentCode
            wsDest.Cells(1, 1).Resize(1, 4).Value = Array("ItemCode", "ItemDescr", "UnitNo", "Qty")
        End If
        
        ' 清空目标表原有数据（保留表头）
        If wsDest.Cells(2, 1).Value <> "" Then
            wsDest.Rows("2:" & wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row).ClearContents
        End If
        
        ' 复制对应ItemCode的数据到目标表
        newRow = 2
        For i = 2 To wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
            If wsSource.Cells(i, "A").Value = currentCode Then
                wsSource.Rows(i).Copy wsDest.Cells(newRow, 1)
                newRow = newRow + 1
            End If
        Next i
        
        ' 清空非首行的ItemCode和ItemDescr列
        If newRow > 2 Then
            wsDest.Range("A3:A" & newRow - 1).ClearContents
            wsDest.Range("B3:B" & newRow - 1).ClearContents
        End If
        
        ' 自动调整ItemDescr列（B列）宽度
        wsDest.Columns("B").AutoFit
    Next currentCode
End Sub

关键修改说明 #

• 按完整ItemCode分组：不再截取前4位字符，而是收集所有完整的唯一ItemCode，为每个代码单独创建工作表
• 清空指定列内容：复制完对应数据后，自动清除目标表中第3行及以后的ItemCode（A列）和ItemDescr（B列）内容
• 自动列宽适配：通过AutoFit方法让ItemDescr列自动匹配该列最长内容的宽度
• 避免重复创建：先检查工作表是否已存在，已存在则复用并清空原有数据（保留表头）

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