Question

我使用VBA将所有唯一值从一个工作表复制到另一个工作表。我的VBA看起来像这样：

Sub UniqueListSample()

Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")


lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row


On Error Resume Next
For i = 1 To lastrow
    If Len(Sheet1.Cells(i, "B")) <> 0 Then
        dictionary.Add shee.Cells(i, "B").Value, 1
    End If
Next

Sheet3.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True

End Sub

这将获取工作表1列B中的所有唯一值，并将它们移动到工作表3列A.我现在尝试添加的是一个函数，它从工作表1中的C列获取相同的行并粘贴它们进入表3第B栏。

有没有简单的方法将其添加到现有的VBA？

Answer 1

请检查一下：

Option Explicit

Sub UniqueListSample()

Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")



lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row


On Error Resume Next
For i = 1 To lastrow
    If Len(Sheet1.Cells(i, "B")) <> 0 Then
        dictionary.Add shee.Cells(i, "B").Value, shee.Cells(i, "c").Value
    End If
Next

With Sheet3

.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)


For i = 1 To dictionary.Count

.Cells(i + 2, 2) = dictionary(Sheet3.Cells(i + 2, 1).Value)


Next

End With

Application.ScreenUpdating = True

End Sub

Answer 2

如果您只想要一个列，则可以使用该项目。我宁愿避免＆＃34; On Error＆＃34;声明 - 如果使用相同的键（下面只会覆盖），下面的方法不会出错。

Sub UniqueListSample()

Application.ScreenUpdating = False

Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet

Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row

With dictionary
    For i = 1 To lastrow
        If Len(Sheet1.Cells(i, "B")) <> 0 Then
            If Not (.Exists(shee.Cells(i, "B").Value)) Then
                .Item(shee.Cells(i, "B").Value) = shee.Cells(i, "C").Value
            End If
        End If
    Next
    Sheet3.Range("A3").Resize(.Count).Value = Application.Transpose(.keys)
    Sheet3.Range("B3").Resize(.Count).Value = Application.Transpose(.items)
End With

Application.ScreenUpdating = True

End Sub

复制相应的行VBA

2 个答案: