复制相应的行VBA

即时通讯使用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 

这将从Sheet 1 Coloum B中获取所有的唯一值，并将它们移动到Sheet 3的Coloum A上。现在我试图添加的是一个函数，它从表1中的Coloum C获取相同的行，并将它们粘贴到Sheet 3的Coloum 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

如果你只想要一列，你可以使用该项目。 我宁愿避免“On Error”语句 – 如果使用相同的密钥（它只是覆盖），下面的方法不会出错。

 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