基于F列前5位拆分保存Excel文件的VBA代码修正请求

需求说明：

• 按F列单元格的前5位字符拆分数据，每个分组生成独立工作簿
• 保存格式：01_03_<F列前5位>_<当前日期yyyymmdd>.xlsx，其中<F列前5位>对应分组标识（如1396A、0001A等）

修正后的VBA代码：

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow As Integer, nRow As Integer, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    Dim i As Integer ' 补充变量声明，避免隐式变体类型
    
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    ' 收集F列前5位的唯一值
    For nRow = 2 To nLastRow
        strColumnValue = Left(CStr(objWorksheet.Range("F" & nRow).Value), 5) ' 转为字符串后取前5位，兼容数值型数据
        If Not objDictionary.Exists(strColumnValue) Then
            objDictionary.Add strColumnValue, 1
        End If
    Next
    
    varColumnValues = objDictionary.Keys
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        
        ' 复制表头，跳过Select/Paste提升效率
        objWorksheet.Rows(1).Copy Destination:=objSheet.Range("A1")
        
        ' 复制对应分组的数据行
        For nRow = 2 To nLastRow
            If Left(CStr(objWorksheet.Range("F" & nRow).Value), 5) = CStr(varColumnValue) Then
                nNextRow = objSheet.Range("A" & objSheet.Rows.Count).End(xlUp).Row + 1
                objWorksheet.Rows(nRow).Copy Destination:=objSheet.Range("A" & nNextRow)
            End If
        Next
        
        ' 自动调整列宽
        objSheet.Columns("A:H").AutoFit
        
        ' 按指定格式保存文件：01_03_<F列前5位>_yyyymmdd.xlsx
        objExcelWorkbook.SaveAs Filename:="C:\Users\User\Desktop\New folder\01_03_" & varColumnValue & "_" & Format(Date, "yyyymmdd") & ".xlsx"
        objExcelWorkbook.Close SaveChanges:=False ' 保存后关闭工作簿，释放资源
    Next
End Sub

关键修改点：

1. 文件名格式修正：在SaveAs语句中加入varColumnValue，实现按F列前5位字符命名，匹配要求的格式
2. 补充变量声明：新增Dim i As Integer，避免隐式变体类型的潜在问题
3. 优化复制逻辑：移除Activate、Select、Paste操作，改用Copy Destination:=直接复制，提升运行效率
4. 数据兼容处理：取F列内容前5位时先转为字符串，避免纯数字单元格转换异常
5. 资源释放：保存后自动关闭生成的工作簿，避免过多文件占用内存

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