修改VBA脚本实现按ItemCode创建独立工作表并适配列宽

修改后的完整代码 #

Sub CreateTabsFromFullItemCode()
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Dim i As Long
    Dim lastRow As Long
    Dim wsDestination As Worksheet
    Dim currentCode As String
    Dim newRow As Long
    Dim lastCode As String
    Dim startRow As Long
    Dim maxDescrWidth As Double
    
    ' 对源数据按ItemCode排序，保证同代码数据连续
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").CurrentRegion.Sort Key1:=.Range("A2:A" & lastRow), Header:=xlYes
    End With
    
    ' 初始化变量，从第一行数据行开始
    lastCode = wsSource.Cells(2, 1).Value
    startRow = 2
    
    For i = 2 To lastRow + 1
        ' 取完整ItemCode，不再截取前4位
        currentCode = wsSource.Cells(i, 1).Value
        
        ' 触发分组处理：当前代码与上一组不同，或遍历到最后一行
        If currentCode <> lastCode Or i = lastRow + 1 Then
            Set wsDestination = Nothing
            On Error Resume Next
            Set wsDestination = ThisWorkbook.Sheets(lastCode)
            On Error GoTo 0
            
            ' 目标工作表不存在则新建
            If wsDestination Is Nothing Then
                Set wsDestination = ThisWorkbook.Sheets.Add(After:=wsSource)
                wsDestination.Name = lastCode
                ' 设置表头
                wsDestination.Cells(1, 1).Value = "ItemCode"
                wsDestination.Cells(1, 2).Value = "ItemDescr"
                wsDestination.Cells(1, 3).Value = "UnitNo"
                wsDestination.Cells(1, 4).Value = "Qty"
                ' 表头加粗增强可读性
                wsDestination.Rows(1).Font.Bold = True
            End If
            
            ' 获取目标表下一个写入行号
            newRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Row + 1
            
            ' 写入分组首行：完整ItemCode和ItemDescr
            wsDestination.Cells(newRow, 1).Value = wsSource.Cells(startRow, 1).Value
            wsDestination.Cells(newRow, 2).Value = wsSource.Cells(startRow, 2).Value
            
            ' 写入分组后续行：仅复制UnitNo和Qty列
            If startRow < i - 1 Then
                wsSource.Range("C" & startRow + 1 & ":D" & i - 1).Copy _
                    wsDestination.Cells(newRow + 1, 3)
            End If
            
            ' 自动调整ItemDescr列宽，同时设置最小宽度避免过窄
            wsDestination.Columns(2).AutoFit
            If wsDestination.Columns(2).ColumnWidth < 15 Then
                wsDestination.Columns(2).ColumnWidth = 15
            End If
            
            ' 更新变量，处理下一组数据
            lastCode = currentCode
            startRow = i
        End If
    Next i
End Sub

关键修改说明 #

• 按完整ItemCode分表：移除原代码中截取ItemCode前4位的逻辑，直接使用完整的ItemCode值作为分组依据，确保每个唯一代码对应独立工作表。
• 优化数据展示格式：
  • 每组数据的首行保留ItemCode和ItemDescr信息，清晰标识分组内容
  • 后续行仅展示UnitNo和Qty，避免重复冗余信息
• 自动适配列宽：通过AutoFit自动调整ItemDescr列（B列）的宽度以匹配最长内容，同时增加最小宽度限制，防止短描述导致列宽过窄影响阅读。
• 增强表头可读性：单独设置表头并加粗，让目标工作表的结构更清晰。

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