Question

我正在尝试从A列中提取字符串并将它们移动到B列，只要它们在B列中不存在。为此，我想制作一个列表并用它扫描所有A列但是，我不确定如何在VBA中这样做。在python中，我记得使用了

的内容

[If (x) not in (List)]

但是同样的方法在Excel中不适合我。

目前，我有以下

Sub GatherAll()

GL = List()
rwcnt = WorksheetFunction.CountA(Range("A:A"))
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long

For i = 2 To rwcnt
    Cells(i, 1).Value = n

我想说点什么

if n not in GL, GL.append(n)
continue

End Sub

如果有人能帮助我，我会非常感激。

Answer 1

尝试根据您的具体需求调整以下代码，看看它是否有帮助。如果您需要帮助，请告诉我们。

Sub MoveUniqueEntries()
    Dim oDict As Object
    Dim rToMove As Range
    Dim rDest As Range
    Dim rLoop As Range

    Set oDict = CreateObject("Scripting.Dictionary")
    Set rToMove = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Columns(1))
    Set rDest = Sheet1.Range("B1")

    For Each rLoop In rToMove
        If oDict.exists(rLoop.Value) Then
            'Do nothing
        Else
            oDict.Add rLoop.Value, 0
            rDest.Value = rLoop.Value
            Set rDest = rDest.Offset(1)
        End If
    Next rLoop
End Sub

Answer 2

在VBA IDE中，您必须添加引用。在工具下拉菜单中选择参考。然后选择＆＃34; Microsoft ActiveX Data Objects 2.8 Library＆＃34;。

Dim rs As New ADODB.Recordset
Dim ws As Excel.Worksheet
Dim lRow As Long

    Set ws = Application.ActiveSheet
    'Add fields to your recordset for storing data.  You can store sums here.
    With rs
        .Fields.Append "Row", adInteger
        .Fields.Append "Value", adInteger
        .Open
    End With

    lRow = 1

    'Loop through and record what is in the first column
    Do While lRow <= ws.UsedRange.Rows.count

        rs.AddNew
        rs.Fields("Row").Value = lRow
        rs.Fields("Value").Value = ws.Range("A" & lRow).Value
        rs.Update

        lRow = lRow + 1
        ws.Range("A" & lRow).Activate
    Loop

    'Now go through and list out the unique values in columnB.
    lRow = 1
    rs.Sort = "value"
    Do While lRow <= ws.UsedRange.Rows.count
        if rs.Fields("value").Value <> strLast then

            ws.Range("B" & lRow).Value = rs.Fields("value").Value

            lRow = lRow + 1
        End if
        strLast = rs.Fields("value").Value
    Loop

Answer 3

跨平台版本（但对于大量值而言会很慢）：

Sub UniquesTester()

    Dim v, u(), i As Long, n As Long
    n = 0
    v = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp)).Value
    ReDim u(1 To UBound(v, 1))
    For i = 1 To UBound(v, 1)
        If IsError(Application.Match(v(i, 1), u, 0)) Then
            n = n + 1
            u(n) = v(i, 1)
        End If
    Next i
    ReDim Preserve u(1 To n)

    Range("c1").Resize(n, 1).Value = Application.Transpose(u)

End Sub

Excel VBA创建列表并仅添加唯一术语

3 个答案: