VBA - 在列中搜索值并在新列中重新排序

Question

列中的

我有多个值（增值数字）但不是连续的行，例如在A1，A5，A8，...... 我需要复制A列中的每个值并将它们粘贴到一个新列中，但是在连续的行中重新排序，例如B1，​​B2，B3，......

以下宏执行此作业但仅在值中包含符号“@”，因为它使用函数“Array”（如果我将@替换为数字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

由于 马可