Need Help with excal macro / vba code which will delete similar numbers and rearrange the table?

Question

Excel Macro code. i need help with macro code where it take off similar number and re arrange the table.
34.00 38.00
38.00 54.00
60.00 75.00
75.00 80.00

than rearrange into
34.00 54.00
60.00 80.00

Answer 1

Here is a fairly simple event handler that will do as you wish simply by double clicking any cell. This assumes your two columns are A:B.



Copy this event handler to the code module for the worksheet containing your date to evaluate:



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _

Cancel As Boolean)

Dim i, j, LastRow

LastRow = Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For i = LastRow To 1 Step -1

For j = LastRow To 1 Step -1

If Cells(i, "A").Value = Cells(j, "B").Value Then

Cells(i, "A").Delete (xlShiftUp)

Cells(j, "B").Delete (xlShiftUp)

End If

Next j

Next i

Target.Offset(0, 1).Select

End Sub

Answer 2

This should delete any non-unique numeric values (non formulaic) from columns A and B and shift all cells up.



For Each c In Range("A:B").SpecialCells( xlCellTypeConstants)

If WorksheetFunction.CountIf(Range("A:B"), c.Value) > 1 Then

Set found = Range("A:B").Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole)

If Unique(found, delItems) Then

start = found.Address

Do

If delItems Is Nothing Then

Set delItems = found

Else

Set delItems = Union(delItems, found)

End If

Set found = Range("A:B").FindNext(found)

Loop While found.Address <> start And (Not found Is Nothing)

End If

End If

Next



delItems.Delete (xlShiftUp)



End Sub



Function Unique(rng1 As Range, rng2 As Range) As Boolean

If (rng2 Is Nothing) Or (rng1 Is Nothing) Then

Unique = True

Else

If Intersect(rng1, rng2).Count >= 1 Then

Unique = False

Else

Unique = True

End If

End If

End Function

Answer 3

this may delete any non-unique numeric values (non formulaic) from columns A and B and shift all cells up. for each c In decision("A:B").SpecialCells( xlCellTypeConstants) If WorksheetFunction.CountIf(decision("A:B"), c.fee) > a million Then Set got here across = decision("A:B").locate(c.fee, LookIn:=xlValues, LookAt:=xlWhole) If unique(got here across, delItems) Then start up = got here across.address Do If delItems Is not something Then Set delItems = got here across Else Set delItems = Union(delItems, got here across) end If Set got here across = decision("A:B").FindNext(got here across) Loop at the same time as got here across.address <> start up And (not got here across Is not something) end If end If next delItems.Delete (xlShiftUp) end Sub function unique(rng1 As decision, rng2 As decision) As Boolean If (rng2 Is not something) Or (rng1 Is not something) Then unique = real Else If Intersect(rng1, rng2).count number >= a million Then unique = pretend Else unique = real end If end If end function