我怎样才能有条件地对一行中的数据进行sorting，使其与第二行的近似数据匹配？

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

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

数据通常会显示为：

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

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

我最初的代码是这样写的：

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中find一个具有必要条件的值（在当前第一行单元值的1.2之内），则将其放置在行1。

所以，假设：

1. 第1行将在所有100个单元格中具有数据值
2. 第2-48行将不会有全部100个单元格中的数据
3. 不包含数据的单元格将为空，并且
4. 我想保持代码限于一次对一行进行sorting（为了安全起见，每个程序运行对照第一行检查并sorting一行）

我如何重写（完全是，如果需要的话）我的代码，以便我可以对数据进行sorting（如第一张图中的示例），以便最好地适合第二张图中的数据结构示例？

提前谢谢你，请原谅，如果这真的是一个令人难以置信的简单的解决scheme，我忽略了！

最好，

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 

希望这可以帮助