如何用VBA实现将未知行数的列数据按50%最大值拆分到两个工作表？

以下是实现需求的完整VBA代码，核心逻辑是按目标列降序排序数据后，将前50%（含最大值）的行复制到指定工作表，剩余行复制到另一个工作表：

Sub SplitDataByValue()
    Dim wsSource As Worksheet
    Dim wsHigh As Worksheet
    Dim wsLow As Worksheet
    Dim lastRow As Long
    Dim splitRow As Long
    Dim targetCol As String ' 目标数据列，根据实际修改，比如"B"表示第二列
    
    ' 定义源工作表和目标列
    Set wsSource = ThisWorkbook.Worksheets("Sheet1") ' 替换为你的数据源工作表名称
    targetCol = "A" ' 替换为存储待比较数据的列
    
    ' 检查并创建目标工作表（如果不存在）
    On Error Resume Next
    Set wsHigh = ThisWorkbook.Worksheets("Офисы с большими расходами")
    If Err.Number <> 0 Then
        Set wsHigh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsHigh.Name = "Офисы с большими расходами"
    End If
    Err.Clear
    
    Set wsLow = ThisWorkbook.Worksheets("Офисы с меньшими расходами")
    If Err.Number <> 0 Then
        Set wsLow = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsLow.Name = "Офисы с меньшими расходами"
    End If
    On Error GoTo 0
    
    ' 清除目标工作表已有数据
    wsHigh.Cells.Clear
    wsLow.Cells.Clear
    
    ' 获取源数据最后一行（包含表头）
    lastRow = wsSource.Cells(wsSource.Rows.Count, targetCol).End(xlUp).Row
    
    ' 如果只有表头，退出子程序
    If lastRow <= 1 Then
        MsgBox "源工作表无有效数据！"
        Exit Sub
    End If
    
    ' 计算拆分点：总数据行（去掉表头）的一半，向上取整确保最大值组包含50%及以上数据
    splitRow = 1 + Application.WorksheetFunction.RoundUp((lastRow - 1) / 2, 0)
    
    ' 对源数据按目标列降序排序（表头不参与排序）
    wsSource.Sort.SortFields.Clear
    wsSource.Sort.SortFields.Add2 _
        Key:=wsSource.Range(targetCol & "2:" & targetCol & lastRow), _
        SortOn:=xlSortOnValues, _
        Order:=xlDescending, _
        DataOption:=xlSortNormal
    With wsSource.Sort
        .SetRange wsSource.Range("A1:" & wsSource.Cells(lastRow, wsSource.Columns.Count).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 复制表头到两个目标工作表
    wsSource.Rows(1).Copy Destination:=wsHigh.Rows(1)
    wsSource.Rows(1).Copy Destination:=wsLow.Rows(1)
    
    ' 复制前半部分（含最大值）到高值工作表
    wsSource.Rows("2:" & splitRow).Copy Destination:=wsHigh.Rows(2)
    
    ' 复制剩余部分到低值工作表
    If splitRow < lastRow Then
        wsSource.Rows(splitRow + 1 & ":" & lastRow).Copy Destination:=wsLow.Rows(2)
    End If
    
    MsgBox "数据拆分完成！"
End Sub

关键代码说明 #

• 目标列与源工作表：修改wsSource和targetCol变量，匹配你的实际数据源位置
• 工作表检查：先判断目标工作表是否存在，避免重复创建报错
• 拆分逻辑：使用RoundUp处理奇数行的情况，确保含最大值的组始终包含至少50%的数据
• 排序操作：对源数据按目标列降序排列，确保最大值集中在前半部分
• 数据复制：先复制表头，再分别复制对应行数据到目标工作表

内容的提问来源于stack exchange，提问作者Гаврилов Life