Question

好的，我对VBA编码很新。

我正在开发一个程序，该程序在列中找到匹配项，并将它们剪切并粘贴到单独的工作表上。我有工作代码，但我希望扩大它，以便有一个输入框，用户可以选择要搜索的程序列，查找匹配，并将这些剪切并粘贴到工作表2.这是我的有，任何帮助都会很棒。我知道代码有点笨拙，所以清理它的任何帮助都会很棒。

谢谢你们。

 Sub removedup()
Dim y As Integer
Dim x As Integer
Dim z As Integer
Dim unique() As String
ReDim unique(0)
Dim dups() As String
ReDim dups(0)
Dim dupFlag As Boolean
Dim dupCount As Integer
Dim rowcount As Integer
Dim sheet2indexer As Integer
Dim rColumn As Range



    Set rColumn = Application.InputBox("Pick Column", , , , , , , 8)

    MsgBox rColumn.Address




'Pre Sort

Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(rColumn.Column)_
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:Z20000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'get array of all unique names
dupFlag = False
x = 1
Do While Sheets(1).Cells(x, rColumn.Column).Value <> ""
    For y = 0 To UBound(unique)
        If Sheets(1).Cells(x, "E").Value = unique(y) Then
            dupFlag = True
        End If
    Next y
    If dupFlag = False Then
        ReDim Preserve unique(UBound(unique) + 1)
        unique(UBound(unique)) = Sheets(1).Cells(x, rColumn.Column).Value
    Else
        dupFlag = False
    End If

x = x + 1

Loop

rowcount = x - 1

'unique(1 to unbound(unique)) now contains one of each entry
'check which values are duplicates, and record

dupCount = 0

For y = 1 To UBound(unique)
    x = 1
    Do While Sheets(1).Cells(x, rColumn.Column).Value <> ""
        If unique(y) = Sheets(1).Cells(x, rColumn.Column).Value Then
            dupCount = dupCount + 1
        End If
        x = x + 1
    Loop
    If dupCount > 1 Then
        'unique(y) is found more than once
        ReDim Preserve dups(UBound(dups) + 1)
        dups(UBound(dups)) = unique(y)
    End If
        dupCount = 0
Next y

sheet2indexer = 0
'now we have a list of all duplicate entries, time to start moving rows
For z = rowcount To 1 Step -1
    For y = 1 To UBound(dups)
        If Sheets(1).Cells(z, rColumn.Column).Value = dups(y) Then
            'current row z is a duplicate
            sheet2indexer = sheet2indexer + 1
            Sheets(1).Rows(z).Cut Sheets(2).Rows(sheet2indexer)
            Sheets(1).Rows(z).Delete
        End If
    Next y
Next z


End Sub

Answer 1

如果要使用InputBox选择范围变量，可以将值8提供给其最后一个参数。然后，您可以选择要工作的范围（或整个列）。

例如：

Sub Test()
    Dim rColumn As Range

    Set rColumn = Application.InputBox("Pick Col", , , , , , , 8)

    MsgBox rColumn.Address
End Sub

用户输入框以选择列以执行操作

1 个答案: