自动细胞运动，最好使用如果/当风格的条件

我正在努力实现的是：

我想完全自动清理导出数据的过程。 我想将溢出行中的数据移动到其预期的列中。 我已经在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