Question

所以，我有一个数据排序问题。

基本上，我想对第2行到第48行的单元格进行排序，使它们低于第1行中的近似值（省略号在下面的图片中用作行内所有其他单元格的占位符;所有行， 1到48，将从EG延伸到IB，使每行总共100个单元格。

数据通常显示为：

但我要求第2行到第48行的数据在其第1行对应物的近似值（1.2以内）内排序，如下所示：

现在对值进行排序，使用第1行作为所有其他行进行排序的主行。如果该行中的单元格值不满足其第1行对应的1.2的条件，则必须将第2-48行中的单元格留空。

我的初始代码是这样编写的：

Sub t()

Dim F As Range
Dim Q As Range

For Each F In Range("EG1:IB1").Cells
    For Each Q In Range("EG2:IB2").Cells
        If Q.Value <= (F.Value + 1.2) Then
            F.Offset(1, 0).Value = Q.Value
            Exit For
        End If
    Next Q
Next F

End Sub

显然，此代码不会产生预期的结果，但我不知道为什么。目的是迭代检查第1行对第2行的数据值，如果在第2行中找到具有必要条件的值（在当前第1行单元格值的1.2内），则将其放在其对应的行下面1.

所以，假设：

第1行将包含所有100个单元格中的数据值，
第2-48行将 NOT 在所有100个单元格中都有数据，
不包含数据的单元格将为空，
我想保持代码限制为一次排序一行（为了安全起见，每个程序运行检查和排序单行与行1）

如何重写（完全，如果需要）我的代码，以便我可以对数据进行排序，如第一张图片中所示，以最适合第二张图片中的数据组织？

提前谢谢你，请原谅我，如果这实际上是一个我忽略的非常简单的解决方案!!

最佳，

Answer 1

横向排序每一行应纠正任何无序值，并在EG1：IB48范围的左端“蜷缩”它们。之后，插入一个新单元格（在右边的行上移动其他值）应该更正位置。

Sub sort_and_push()
    Dim rw As Long, cl As Long

    With Worksheets("Sheet4")   '<~~ set this correctly!
        With .Range("EG1:IB48")
            With .Rows(1)
                .Cells.sort Key1:=.Rows(1), Order1:=xlAscending, _
                            Orientation:=xlLeftToRight, Header:=xlNo
            End With
            For rw = 2 To .Rows.Count
                .Rows(rw).Cells.sort Key1:=.Rows(rw), Order1:=xlAscending, _
                            Orientation:=xlLeftToRight, Header:=xlNo
                For cl = 1 To 99
                    If IsEmpty(.Cells(rw, cl)) Then
                        Exit For
                    ElseIf .Cells(rw, cl).Value2 > .Cells(1, cl + 1).Value2 Then
                        .Cells(rw, cl).Insert Shift:=xlToRight
                    End If
                Next cl
            Next rw
        End With
    End With
End Sub

Answer 2

尝试这样的事情：

Option Explicit

Sub t()

    Dim ws As Excel.Worksheet
    Dim F As Excel.Range
    Dim Q As Excel.Range
    Dim J As Long
    Dim s As String
    Dim SortRange As Excel.Range
    Dim HeaderRange As Excel.Range

    Const COL1 As Long = 137
    Const COLN As Long = 236

    ' This is the row you're sorting
    ' You'll probably want to make this a loop
    ' variable to sort all rows
    Const RR As Long = 2

    ' As a safety measure I'm specifying which worksheet to sort
    ' to make sure we don't accidentally sort the wrong data.
    ' Modify this to suit your purposes.
    Set ws = ThisWorkbook.Worksheets(1)
    Set SortRange = ws.Range(ws.Cells(RR, COL1), ws.Cells(RR, COLN))
    Set HeaderRange = ws.Range(ws.Cells(1, COL1), ws.Cells(1, COLN))

    ' As a first step, I'm sorting row 2.
    ' If the values out of order there's a potential to accidentally
    ' overwrite data. For example if you had
    '       EG  EH
    '   1   2   5
    '   2   4   3
    ' moving the 4 in row two to column EH would overwrite the 3.
    ' If the values are already sorted, you could skip this.
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add _
        Key:=SortRange, _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal

    With ws.Sort
        .SetRange SortRange
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With


    ' I've reversed the nested-ness of the Q and F loops
    ' Also, I'm traversing the Q loop in reverse order to avoid
    For J = COLN To COL1 Step -1
    ' For J = 142 To 137 Step -1    ' short loop for testing
        Set Q = ws.Cells(RR, J)
        ' Skip blank cells
        If Not IsEmpty(Q.Value) Then
            ' Do the comparison to Row 1
            For Each F In HeaderRange.Cells
                If Q.Value <= (F.Value + 1.2) Then
                    ws.Cells(2, F.Column).Value = Q.Value   ' Write to correct column
                    If F.Column <> Q.Column Then
                        Q.Clear           ' Get rid of old value
                    End If
                    Exit For
                End If
            Next F
        End If
    Next J

    GoTo CleanUp

CleanUp:
        Set F = Nothing
        Set Q = Nothing
        Set SortRange = Nothing
        Set HeaderRange = Nothing
        Set ws = Nothing

Exit Sub


End Sub

希望这有帮助

我如何有条件地将一行数据排序到第二行中的近似数据匹配？

2 个答案: