Sub moveemail()
Dim ws As Worksheet
Dim thisCell As Range, nextCell As Range, lookAt As Range
Dim foundAt As String, lookFor As String
Dim lastRow As Long
lookFor = "@"
On Error GoTo Err
'get last populated cell
Set ws = Application.ActiveSheet
With ws
If WorksheetFunction.CountA(Cells) > 0 Then
lastRow = Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
End With
' go cell by cell looking for @ from row 1 to row 10000
Set lookAt = ActiveSheet.Range("S1:U" & lastRow)
Set thisCell = lookAt.Find(what:=lookFor, LookIn:=xlValues, lookAt:=xlPart, SearchDirection:=xlNext)
If Not thisCell Is Nothing Then
Set nextCell = thisCell
Do
Set thisCell = lookAt.FindNext(After:=thisCell)
If Not thisCell Is Nothing Then
foundAt = thisCell.Address
thisCell.Copy Range("V" & thisCell.Row)
thisCell.ClearContents
Else
Exit Do
End If
If thisCell.Address = nextCell.Address Then Exit Do
Loop
Else
'MsgBox SearchString & " not Found"
Exit Sub
End If
Err:
'MsgBox Err.Number
Exit Sub
End Sub
2条答案
按热度按时间xoefb8l81#
您可以使用以下公式转换为V1来实现这一点:
公式需要按数组公式输入,即Ctrl-Shift-Enter。
k10s72fa2#
按Alt+F11打开Visual Basic编辑器,然后单击“插入”、“模块”。将其粘贴进去。或者,只需下载示例文件here。然后在“视图/宏”下,将出现movemail()例程。运行该例程。
我接受支票,汇票,贝宝,比特币...:-)J/J享受吧。