自动移动单元格，最好使用if/ style样式条件。
自动移动单元格，最好使用if/ style样式条件。
提问于 2015-10-12 05:14:46
我想要达到的目标：
我想完全自动化清理导出数据的过程。我希望将溢出行中的数据移动到它们的预期列中。我在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一旦数据在正确的列中，我需要将移动自动化到正确的行中。我可以很容易地让他们向上移动，但如果一个联系人没有电子邮件地址(例如)，那么当他们移动时，电子邮件将出现在错误的行中。
回答 1
Stack Overflow用户
回答已采纳
发布于 2015-10-12 05:45:03
像这样的事情应该有效：
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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/33073689
复制相关文章
相似问题
腾讯云开发者
