How do I compare absolute difference between column and one target cell, and afterward, sort by Abs diff?

问题

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).

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):

This is the code for the userform:

 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

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

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

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:

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?

For @Mikku this is the latest error!:

回答1:

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.

Change:

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

With:

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

Change the Worksheet Event Code to this: (Untested)

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

Demo:

Updated Code:

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

来源：https://stackoverflow.com/questions/57511457/how-do-i-compare-absolute-difference-between-column-and-one-target-cell-and-aft

标签

excel

vba

sorting