VBA处理Excel数据：提取最右侧值及次右侧值至指定列

针对你的需求，下面提供两种可通用识别文本与数值的VBA实现方案，解决你之前遇到的文本识别受阻问题：

方案一：逐行遍历+数值判断 #

核心逻辑：遍历目标区域的每一行，逐个单元格判断是否为数值（跳过文本内容），记录该行所有数值单元格的位置，最后提取倒数第一个（贷方）和倒数第二个（借方）数值，写入新列。

Sub ExtractDebitCredit()
    Dim targetRange As Range
    Dim rowRange As Range
    Dim cell As Range
    Dim numCells As Collection
    Dim outputRow As Integer
    
    Set targetRange = ThisWorkbook.ActiveSheet.Range("A1:G200")
    outputRow = 1 ' 新列起始行，可按需调整
    
    For Each rowRange In targetRange.Rows
        Set numCells = New Collection
        ' 遍历当前行单元格，收集数值单元格
        For Each cell In rowRange.Cells
            ' 通用判断：单元格为非空数值（自动跳过文本、空单元格）
            If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
                numCells.Add cell
            End If
        Next cell
        
        ' 提取并处理数值单元格
        If numCells.Count >= 2 Then
            ' 借方：倒数第二个数值单元格
            ThisWorkbook.ActiveSheet.Cells(outputRow, "H").Value = numCells(numCells.Count - 1).Value
            ' 贷方：倒数第一个数值单元格
            ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = numCells(numCells.Count).Value
            ' 可选：清空原单元格内容
            numCells(numCells.Count - 1).ClearContents
            numCells(numCells.Count).ClearContents
        ElseIf numCells.Count = 1 Then
            ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = numCells(1).Value
            numCells(1).ClearContents
        End If
        
        outputRow = outputRow + 1
    Next rowRange
    
    Set numCells = Nothing
    Set targetRange = Nothing
End Sub

方案二：SpecialCells筛选数值+按行分组 #

核心逻辑：先一次性筛选出目标区域内的所有数值单元格，再按行分组，找到每行的最后两个数值单元格进行提取，效率更高。

Sub ExtractDebitCredit_SpecialCells()
    Dim numCells As Range
    Dim cell As Range
    Dim currentRow As Integer
    Dim rowCellList As Collection
    Dim outputRow As Integer
    
    On Error Resume Next
    ' 筛选目标区域内的所有数值单元格
    Set numCells = ThisWorkbook.ActiveSheet.Range("A1:G200").SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0
    
    If numCells Is Nothing Then
        MsgBox "目标区域无数值单元格"
        Exit Sub
    End If
    
    outputRow = 1
    currentRow = numCells(1).Row
    Set rowCellList = New Collection
    
    For Each cell In numCells
        ' 换行时处理上一行的数值单元格
        If cell.Row <> currentRow Then
            If rowCellList.Count >= 2 Then
                ThisWorkbook.ActiveSheet.Cells(outputRow, "H").Value = rowCellList(rowCellList.Count - 1).Value
                ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = rowCellList(rowCellList.Count).Value
                rowCellList(rowCellList.Count - 1).ClearContents
                rowCellList(rowCellList.Count).ClearContents
            ElseIf rowCellList.Count = 1 Then
                ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = rowCellList(1).Value
                rowCellList(1).ClearContents
            End If
            
            Set rowCellList = New Collection
            currentRow = cell.Row
            outputRow = outputRow + 1
        End If
        rowCellList.Add cell
    Next cell
    
    ' 处理最后一行的数值单元格
    If rowCellList.Count >= 2 Then
        ThisWorkbook.ActiveSheet.Cells(outputRow, "H").Value = rowCellList(rowCellList.Count - 1).Value
        ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = rowCellList(rowCellList.Count).Value
        rowCellList(rowCellList.Count - 1).ClearContents
        rowCellList(rowCellList.Count).ClearContents
    ElseIf rowCellList.Count = 1 Then
        ThisWorkbook.ActiveSheet.Cells(outputRow, "I").Value = rowCellList(1).Value
        rowCellList(1).ClearContents
    End If
    
    Set rowCellList = Nothing
    Set numCells = Nothing
End Sub

关键说明 #

• 通用文本识别：通过IsNumeric(cell.Value)判断单元格内容是否为数值，无论文本内容是什么，只要不是数值就自动跳过，解决了你之前无法通用识别文本的问题。
• 新列位置：代码默认用H列存借方、I列存贷方，可按需修改Cells(outputRow, "H")中的列标识。
• 清空原内容：代码保留了清空原数值单元格的逻辑，若不需要可删除对应的.ClearContents行。

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