Excel VBA按数值阈值将单列数据拆分至两个新建列

需要将名为Total Board Quantit列的数据拆分写入两个新建列，拆分规则如下：

• Total Boards列存储Total Board Quantit列中数值大于28.01的所有值
• Total Pallets列存储Total Board Quantit列中数值小于等于28的所有值
• Total Board Quantit列中数值小于1的数据需过滤不显示，逻辑内置在宏代码中

现有代码存在以下核心错误，导致运行结果不符合预期：

1. 表头查找目标错误：需要处理的源列是Total Board Quantit，但代码中Find方法查找的是Total Pallet Quantit，从一开始就定位错了待处理的列
2. 新列赋值写反：插入新列时，原列右侧第一列是Total Pallets、第二列是Total Boards，但数组循环中把<=28的Pallets值写到了第二列、>28.01的Boards值写到了第一列，列位置完全颠倒
3. 小于1的过滤逻辑无效：仅对固定范围A1:P247写死了筛选规则，既没有适配实际数据行数/列位置，数组处理环节也没有加入<1数值的判断，不符合过滤要求
4. 错误捕获逻辑混乱：删除旧DATA表后开启的On Error Resume Next没有及时关闭，会吞掉后续表头查找、数据读取环节的所有报错，导致代码出错后静默运行产生异常结果
5. 变量声明不全：lastRow、x、num变量未显式声明，和开头的Option Explicit规则冲突，容易产生类型隐式转换错误
6. 数据范围写死：自动筛选范围、取数行数逻辑没有动态适配实际导入的数据，数据量变化时直接失效

Option Explicit

Sub DATA()
    Dim ws As Worksheet
    Dim fName As Variant, wb As Workbook
    Dim rngSourceHeader As Range, rngHeaders As Range
    Dim arrIn, arrOut As Variant
    Dim lastRow As Long, x As Long
    Dim num As Variant
    
    ' 删除已存在的旧DATA表
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("DATA").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    ' 选择要导入的源文件
    Application.EnableEvents = False
    fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
    If fName = False Then
        MsgBox "No SAP Data selected!"
        Application.EnableEvents = True
        Exit Sub
    End If

    ' 导入数据到当前工作簿
    Set wb = Workbooks.Open(fName)
    wb.Sheets(1).Copy before:=ThisWorkbook.Sheets(2)
    ActiveSheet.Name = "DATA"
    Set ws = ActiveSheet ' 直接绑定DATA表，避免后续ActiveSheet指向错误
    wb.Close False
    Application.EnableEvents = True
    
    ' 定位源数据列
    Set rngHeaders = ws.Range("1:1")
    Set rngSourceHeader = rngHeaders.Find(what:="Total Board Quantit", After:=ws.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
    If rngSourceHeader Is Nothing Then
        MsgBox "未找到Total Board Quantit列，请检查源数据！"
        Exit Sub
    End If

    ' 插入两个新列
    rngSourceHeader.Offset(0, 1).EntireColumn.Insert
    rngSourceHeader.Offset(0, 1).Value = "Total Pallets"
    rngSourceHeader.Offset(0, 2).EntireColumn.Insert
    rngSourceHeader.Offset(0, 2).Value = "Total Boards"
  
    ' 动态获取数据最后一行，按源数据列定位不依赖A列
    lastRow = ws.Cells(ws.Rows.Count, rngSourceHeader.Column).End(xlUp).Row
    
    ' 读取源数据到数组
    arrIn = rngSourceHeader.Offset(1, 0).Resize(lastRow - 1, 1).Value
    ReDim arrOut(1 To UBound(arrIn), 1 To 2)

    ' 循环处理数值
    For x = 1 To UBound(arrIn)
        num = arrIn(x, 1)
        ' 跳过空值和非数值内容
        If IsNumeric(num) Then
            ' 小于1的数值直接跳过，实现内置过滤
            If num >= 1 Then
                If num <= 28 Then
                    ' <=28写入第一列对应Total Pallets
                    arrOut(x, 1) = num
                ElseIf num >= 28.01 Then
                    ' >28.01写入第二列对应Total Boards
                    arrOut(x, 2) = num
                End If
            End If
        End If
    Next x
    
    ' 把处理完的数组写回表格
    rngSourceHeader.Offset(1, 1).Resize(UBound(arrIn), 2).Value = arrOut
    
    ' 动态开启筛选，隐藏源列小于1的行
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, rngSourceHeader.Column + 2)).AutoFilter _
        Field:=rngSourceHeader.Column, _
        Criteria1:=">=1"
        
End Sub

• 所有范围、行数列数都做了动态适配，不管源数据列在什么位置、有多少行都能正常运行
• 移除了会吞掉错误的无效On Error Resume Next，加入了源列不存在的提示
• 修正了列定位、列赋值的顺序错误
• 在数组循环环节内置了<1数值的跳过逻辑，同时搭配自动筛选隐藏不符合要求的行
• 所有变量都显式声明，避免隐式类型转换错误
• 直接绑定DATA工作表对象，避免ActiveSheet跳转导致的范围定位错误

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