优选使用if / when样式条件自动化细胞运动

Question

我想要实现的目标：

我希望完全自动化清理导出数据的过程。 我想将溢出行中的数据移动到它们的预期列中。我在VBA中尝试了以下代码。 （这是尝试识别电子邮件中的@符号，并分别将所有电子邮件地址移动到右侧两个位置）。

Sub qwerty()
    Dim D As Range, r As Range
    Set D = Intersect(ActiveSheet.UsedRange, Range("D:D"))

    For Each r In D
        If Left(r.Text, 2) = "@" Then
            r.Copy r.Offset(0, 1)
            r.Clear
        End If
    Next r
End Sub

一旦数据在正确的列中，我需要自动移动到正确的行。我可以轻松地将它们升级，但如果一个联系人没有电子邮件地址（例如），那么当电子邮件向上移动时，电子邮件将会出现错误的行。

Answer 1

这样的事情应该有效：

Sub Tester()
    Dim rw As Range,  currRow As Long
    Dim v, col As Long

    Set rw = ActiveSheet.Rows(2)
    currRow = 0

    Do While rw.Row <= ActiveSheet.UsedRange.Rows.Count

        If rw.Cells(2).Value <> "" Then
            currRow = rw.Row 'moving "overflow" items to this row...
        Else
            If currRow > 0 Then
                v = rw.Cells(4).Value
                col = 0

                'Figure out which column item should be moved to...
                ' "[" is a special character to "Like", so needs to be
                '      enclosed in "[]"
                If v Like "[[]M]:*" Then
                    col = 8
                ElseIf v Like "[[]E]:*" Then
                    col = 6
                ElseIf v Like "[[]H]:*" Then
                    col = 7
                ElseIf v Like "[[]Address]:*" Then
                    col = 9
                End If
                'Got a pattern match, so move this item...
                'Change ".Copy" to ".Cut" when you're done testing...

                If col > 0 Then rw.Cells(4).Copy ActiveSheet.Cells(currRow, col)
            End If
        End If
        Set rw = rw.Offset(1, 0) 'next row....
    Loop
End Sub