Excel VBA宏改造：通过InputBox自定义去重数据源与输出位置

Got it, let's tweak your existing VBA macro to add the interactive selection feature you're asking for. This updated version lets you manually pick both the source range with duplicates and the target starting cell for unique values using intuitive InputBoxes—no more fixed column restrictions!

Sub ExtractUniqueValues()
    Dim d As Object, c As Variant, i As Long
    Dim sourceRange As Range, targetRange As Range
    
    ' Initialize dictionary to store unique values
    Set d = CreateObject("Scripting.Dictionary")
    
    ' Prompt user to select the source range with duplicates
    On Error Resume Next
    Set sourceRange = Application.InputBox( _
        Prompt:="Select the range containing duplicate values:", _
        Title:="Choose Source Range", _
        Type:=8)
    On Error GoTo 0
    
    ' Exit if user cancels or selects nothing
    If sourceRange Is Nothing Then
        MsgBox "No source range selected. Macro cancelled.", vbInformation
        Exit Sub
    End If
    
    ' Check for empty source range
    If sourceRange.Cells.Count = 0 Then
        MsgBox "Selected source range is empty. Macro cancelled.", vbExclamation
        Exit Sub
    End If
    
    ' Convert source range to array for faster processing
    c = sourceRange.Value
    
    ' Populate dictionary with unique values (skip empty cells)
    For i = 1 To UBound(c, 1)
        If Not IsEmpty(c(i, 1)) Then
            d(c(i, 1)) = 1
        End If
    Next i
    
    ' Prompt user to select the target starting cell
    On Error Resume Next
    Set targetRange = Application.InputBox( _
        Prompt:="Select the starting cell for unique values:", _
        Title:="Choose Target Cell", _
        Type:=8)
    On Error GoTo 0
    
    ' Exit if user cancels or selects nothing
    If targetRange Is Nothing Then
        MsgBox "No target cell selected. Macro cancelled.", vbInformation
        Exit Sub
    End If
    
    ' Paste unique values to the target range
    If d.Count > 0 Then
        targetRange.Resize(d.Count).Value = Application.Transpose(d.keys)
        MsgBox "Success! Extracted " & d.Count & " unique values.", vbInformation
    Else
        MsgBox "No unique values found in the source range.", vbExclamation
    End If
    
    ' Clean up objects
    Set d = Nothing
    Set sourceRange = Nothing
    Set targetRange = Nothing
End Sub

Key Updates Explained: #

• Interactive Range Picking: Uses Application.InputBox(Type:=8) which lets you click and select ranges directly in your workbook, instead of typing cell addresses manually.
• Error & Edge Case Handling: Includes checks for cancelled selections, empty source ranges, and cases where no unique values exist, with clear, user-friendly messages.
• Empty Cell Skipping: Ignores blank cells in the source range so you don't end up with unwanted blank entries in your unique values list.
• Flexible Target: Lets you choose any starting cell for the output, not just a fixed cell like B2.

How to Use: #

1. Open your Excel workbook and press Alt + F11 to launch the VBA Editor.
2. Insert a new module (right-click your workbook in the Project Explorer > Insert > Module).
3. Paste the code above into the module.
4. Run the macro by pressing F5, or assign it to a workbook button for quicker access.

内容的提问来源于stack exchange，提问作者Spons