Message box inputs for a working macro, can anyone help?

[rkol297]

Below is a code that I use to remove duplicates from column "L" based on dates in column "K". Basically this code works perfectly fine, however, what I want to do is have a message box pop up when the macro is run to ask which column contains duplicates? and have the response typed in set the value for the code replacing "L". A second box would then pop up and ask where are the dates to be analyzed and have this response set the value for what is now "K" in the code below.




Sub NewestReorder()
Dim Rng As Range
Dim LastRow As Long
Dim i As Long
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
Set Rng = Range("L1:K" & LastRow)
With Rng
.Sort key1:=Range("L1"), order1:=xlAscending, key2:=Range("K1"), order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
For i = LastRow To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, "L"), Cells(i, "L")), Cells(i, "L")) > 1 Then
Rows(i).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Mohammad Basem]

Try this,

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub NewestReorder()

    Dim Rng As Range
    Dim LastRow As Long
    Dim i As Long
    Dim sDupColumn As String, sDateColumn As String

    sDupColumn = InputBox("Specify column letter which contains duplicates", "Duplicate Column")
    If sDupColumn = "" Then Exit Sub        [COLOR="Green"]'* Empty value entered or action cancelled[/COLOR]
    sDateColumn = InputBox("Specify column letter of dates to be analyzed", "Date Column")
    If sDateColumn = "" Then Exit Sub       [COLOR="Green"]'* Empty value entered or action cancelled[/COLOR]

    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, sDupColumn).End(xlUp).Row
    Set Rng = Range(sDupColumn & "1:" & sDateColumn & LastRow)

    With Rng
        .Sort key1:=Range(sDupColumn & 1), order1:=xlAscending, key2:=Range(sDateColumn & 1), _
            order2:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom
    End With
    For i = LastRow To 2 Step -1
        If WorksheetFunction.CountIf(Range(Cells(2, sDupColumn), Cells(i, sDupColumn)), Cells(i, sDupColumn)) > 1 Then
            Rows(i).Delete
        End If
    Next i
    Application.ScreenUpdating = True

End Sub[/COLOR][/SIZE][/FONT]

 

[rkol297]

Works perfectly thank you!

 

[Mohammad Basem]

Al-hamdullah, glad I could help and thank you for the feedback!