如何比较列和一个目标单元格之间的绝对差，然后按Abs diff排序? [英] How do I compare absolute difference between column and one target cell, and afterward, sort by Abs diff?

问题描述

我正在尝试在Excel中使用VBA创建记分板.当用户单击按钮进入时(请参见下图)，他们将在用户表单中键入其姓名，ID和数字答案(因此需要填写3个文本框).

I am trying to create a scoreboard using VBA in Excel. When users click on the button to enter (See image below), they will key in their names, id and numeric answer in a user form (So 3 text boxes for them to fill up).

用户单击用户表单中的提交后，该值应保存在工作表1中以进行校对(请注意 Cell D2 中的4,000，稍后再进行详细说明):

After the user clicks submit in the userform, the value should be saved in Sheet 1 for collation (take note of the 4,000 in Cell D2, more on it later):

这是用户表单的代码:

 Private Sub CommandButton1_Click()
 If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then

 If MsgBox("Your details are not complete! Do you want to continue?", vbQuestion + vbYesNo) <> vbYes Then
 Exit Sub
 End If
 End If

Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value

ActiveCell.Offset(1, 0).Select

Call resetform

End Sub
Sub resetform()

TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
UserForm1.TextBox1.SetFocus

End Sub


Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsNumeric(TextBox3.Value) Then
    MsgBox "Only numbers are allowed"
    Cancel = True
End If
End Sub

通过右击，当用户单击提交答案"命令按钮时，这些值将使用上面的代码相应地保存在 Sheet1 中.

By right, when users click on the submit answer command button, the values will be saved accordingly in Sheet1 with the code above.

但是，我的问题现在出现在这里.我想按绝对差异对值进行排序.即我想将 Sheet1 的 Col C 中的所有数值答案与 Sheet2 的 C3 中的目标答案进行比较代码>.:

However, my issue arises here now. I want to sort the values by absolute differences. I.e I want to compare all the numeric answers in Col C of Sheet1, to the target answer in Cell C3 of Sheet2.:

计算绝对差后，我想按照绝对差按升序对行进行排序.这是排序代码:

After calculating the absolute differences, I want to sort the rows according to the absolute differences in Ascending order. This is the code for the sorting:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant

If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For i = 1 To Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    calc = Sheet1.Cells(i + 1, "C").Value
    test = Sheet2.Cells(3, 3).Value
    Sheet1.Cells(i + 1, "D").Value = Abs(test - calc)
    Application.EnableEvents = False
    Range("A:D").Sort Key1:=Range("D2"), _
          Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom
    Application.EnableEvents = True

Next i

End If
End Sub

但是，当我清除 Sheet1 中的字段时，会出现 Cell D2 中的4,000.(我猜这与目标答案中的4,000减去0有关，因为这些字段为空白.)如果我有新条目，并且差异非常大，则工作表会变得混乱，看起来像这样:

However, when I clear my fields in Sheet1, the 4,000 in Cell D2 appears. (I'm guessing it has to do with the 4,000 in the target answer minusing 0 since the fields are blank.) If I have new entries, and the difference is very huge, the sheet becomes messed up and looks like this:

当我输入另一个具有巨大绝对差的数字时，将重复4,000，并用新的最大绝对差值替换之前的最大绝对差.有人知道为什么吗?

When I key in another number with a huge absolute difference, the 4,000 is repeated and the previous largest absolute difference is replaced with the new largest absolute difference value. Does anyone know why?

对于@Mikku，这是最新的错误！:

For @Mikku this is the latest error!:

推荐答案

我认为这可以解决您的问题.看起来您在运行Userform之前正在选择其他任何单元格，这又是这2个空白行的原因.尝试下面的方法，告诉我是否仍在发生.

I think this will solve your problem. Looks like you are selecting any other cell before running the Userform, which in turn is the reason for those 2 blank rows. Try the Below and tell me if it's still happening.

更改:

Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value

ActiveCell.Offset(1, 0).Select

使用方式:

Dim last As Long
With Worksheets("Sheet1")

last = .Cells(.Rows.Count, "A").End(xlUp).row
.Range("A" & last + 1).Value = TextBox1.Value
.Range("B" & last + 1).Value = TextBox2.Value
.Range("C" & last + 1).Value = TextBox3.Value

End With

将工作表事件代码更改为此:(未经测试)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant

If Not Intersect(Target, Range("C:C")) Is Nothing Then
    Application.EnableEvents = False


test = Worksheets("Sheet2").Cells(3, 3).Value

With Worksheets("Sheet1")

For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row

    calc = .Cells(i, "C").Value
    .Cells(i, "D").Value = Abs(test - calc)

Next i

    .Range("A:D").Sort Key1:=.Range("D2"), _
          Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom
    Application.EnableEvents = True

End With
End If
End Sub

演示:

更新代码:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant

If Not Intersect(Target, Range("E:E")) Is Nothing Then
    Application.EnableEvents = False

Dim lst As Long
test = Worksheets("Target Answer").Cells(3, 3).Value

With Worksheets("Consolidation")
lst = .Cells(.Rows.Count, "C").End(xlUp).Row

For i = 3 To lst

    calc = .Cells(i, "E").Value
    .Cells(i, "F").Value = Abs(test - calc)

Next i

    .Range("C2:F" & lst).Sort Key1:=.Range("F3"), _
          Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom
    Application.EnableEvents = True

End With
End If
End Sub

这篇关于如何比较列和一个目标单元格之间的绝对差，然后按Abs diff排序?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！