VBA按排序列条件复制数据 保持类别与对应名称匹配

• 原有可运行逻辑：将Sheet1中A列从第2行开始的类别值复制后按字母升序排序，写入Sheet2的B列第3行起的位置
• 扩展需求：将Sheet1中B列从第2行开始、与类别对应的名称内容，同步写入Sheet2的E列第3行起的位置
• 约束规则：类别取值仅为H、H/R、H/R/I三类，写入Sheet2后类别已按字母排序，对应名称必须和所属类别严格匹配，禁止单独对名称列排序导致错位
• 初始数据效果：
  
• 目标实现效果：
  

原有代码存在多处逻辑错误，无法实现匹配要求：

1. 仅单独对Sheet2的B列类别做排序，未同步关联对应的名称数据，直接导致类别和名称错位
2. 多条件判断分支语法错误：VBA中多条件判断需使用ElseIf，连续写Else会导致所有不满足第一个If条件的行全部进入第一个分支，被强制修改为H/R，永远不会走到H/R/I的判断逻辑，还会篡改Sheet1的原始A列数据
3. 逐行复制、激活工作表、选中单元格的写法效率极低，且E列粘贴行号使用i+1计算，和排序后的B列行号完全不对应，进一步加剧数据错位
4. 循环中删除空单元格的逻辑会反复触发整列操作，容易误删其他有效数据

Private Sub Button1_Click()
    ' 配置常量，可根据实际需求调整
    Const sName As String = "Sheet1"   ' 源工作表名
    Const sfRow As Long = 2            ' 源数据起始行
    Const sCatCol As Long = 1          ' 源表类别列（A列）
    Const sNameCol As Long = 2         ' 源表名称列（B列）
    
    Const dName As String = "Sheet2"   ' 目标工作表名
    Const dfRow As Long = 3            ' 目标数据起始行
    Const dCatCol As Long = 2          ' 目标表类别写入列（B列）
    Const dNameCol As Long = 5         ' 目标表名称写入列（E列）
    
    Const tipMsg As String = "类别与对应名称已按要求排序写入完成"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    ' 计算源表最后一行有效数据行号
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCatCol).End(xlUp).Row
    Dim dataCount As Long: dataCount = slRow - sfRow + 1
    If dataCount < 1 Then
        MsgBox "源表未检测到有效数据", vbExclamation
        Exit Sub
    End If
    
    ' 一次性读取源数据到数组，避免逐格操作提升效率
    Dim sourceArr As Variant
    sourceArr = sws.Range(sws.Cells(sfRow, sCatCol), sws.Cells(slRow, sNameCol)).Value
    
    ' 按类别列升序排序数组，排序时同步交换对应名称，保证绑定关系不脱节
    Dim i As Long, j As Long, tempCat As String, tempName As String
    For i = LBound(sourceArr, 1) To UBound(sourceArr, 1) - 1
        For j = i + 1 To UBound(sourceArr, 1)
            If sourceArr(i, 1) > sourceArr(j, 1) Then
                tempCat = sourceArr(j, 1)
                tempName = sourceArr(j, 2)
                sourceArr(j, 1) = sourceArr(i, 1)
                sourceArr(j, 2) = sourceArr(i, 2)
                sourceArr(i, 1) = tempCat
                sourceArr(i, 2) = tempName
            End If
        Next j
    Next i
    
    ' 清空目标区域旧数据，避免残留历史内容
    dws.Range(dws.Cells(dfRow, dCatCol), dws.Cells(dws.Rows.Count, dCatCol)).ClearContents
    dws.Range(dws.Cells(dfRow, dNameCol), dws.Cells(dws.Rows.Count, dNameCol)).ClearContents
    
    ' 拆分排序后的数据，一次性写入目标位置
    Dim catArr As Variant, nameArr As Variant
    ReDim catArr(1 To dataCount, 1 To 1)
    ReDim nameArr(1 To dataCount, 1 To 1)
    For i = 1 To dataCount
        catArr(i, 1) = sourceArr(i, 1)
        nameArr(i, 1) = sourceArr(i, 2)
    Next i
    dws.Cells(dfRow, dCatCol).Resize(dataCount, 1).Value = catArr
    dws.Cells(dfRow, dNameCol).Resize(dataCount, 1).Value = nameArr
    
    MsgBox tipMsg, vbInformation
End Sub

• 全程采用数组操作，不修改Sheet1原始数据，不会出现源数据被篡改的问题
• 排序时同步交换类别和对应名称，从根本上避免两类数据错位
• 无逐行复制、选中/激活工作表的低效操作，数据量较大时运行速度优势明显
• 写入前自动清空目标列旧数据，不会残留历史内容
• 所有位置参数都定义为顶部常量，后续调整列位置、起始行时无需修改核心逻辑

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