VBA – 在列中search值并将其重新排列在新列中

在列中我有多个值（增值税号），但不是在连续的行，例如在A1，A5，A8，…我需要从列A复制每个值并粘贴到一个新的列，但重新sorting在连续的行，例如B1，​​B2，B3 …

下面的macros是做这个工作的，但是只有在它包含符号“@”的地方，因为它使用了函数“Array”（如果我用数字replace@，例如1,2,3,4,5,6,7， 8,9，我多次获得相同的增值税号码，我不需要）。

Sub Copy_To_Another_Sheet_1() Dim FirstAddress As String Dim MyArr As Variant Dim Rng As Range Dim Rcount As Long Dim I As Long Dim NewSh As Worksheet With Application .ScreenUpdating = False .EnableEvents = False End With MyArr = Array("@") Set NewSh = Sheets("Sheet2") With Sheets("Sheet2").Range("A1:A100") Rcount = 0 For I = LBound(MyArr) To UBound(MyArr) 'If you use LookIn:=xlValues it will also work with a 'formula cell that evaluates to "@" 'Note : I use xlPart in this example and not xlWhole 'MyArr(I) Set Rng = .Find(What:=MyArr(I), _ After:=.Cells(.Cells.Count), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then FirstAddress = Rng.Address Do Rcount = Rcount + 1 NewSh.Range("A" & Rcount).Value = Rng.Value ' Use this if you only want to copy the value ' NewSh.Range("A" & Rcount).Value = Rng.Value Set Rng = .FindNext(Rng) Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress End If Next I End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

感谢Marco