Excel 直到选择代码结束为止

我希望运行一个Excel VBA循环代码，在“G”列中搜索出现的任何日期，然后对该日期执行操作，然后移动到选择中出现的下一个日期。我的问题是，一旦代码到达工作表的底部（或选择的末尾），它就会在部分的顶部重新启动并再次循环。我需要代码在到达文档末尾（在本例中是选择的末尾）时停止。关于如何实现这一点有什么想法吗

以下是我目前的代码：

Sub Move_Dates_To_Column()
Dim Cell As Range
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set SelectedRange = Sheets("Sheet1").Range("G1:G9000")
Set FindDate = Sheets("Sheet1").Range("G1:G9000").Find(What:="**/**/****", LookIn:=xlFormulas)
'    Do Until FindDate Is Nothing
 '           If Not FindDate Is Nothing Then
 For Each Cell In SelectedRange
Cell.Select
If Not IsEmpty(ActiveCell.Value) Then
Cells.Find(What:="**/**/****", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
ActiveCell.Copy
ActiveCell.Offset(2, -7).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(2, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
ActiveCell.Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
'ActiveCell.Offest(1, 0).Select
End If
Next Cell
End Sub

---

*请注意，在整个范围内都有空格。范围应为“范围（G:G）”

以下是一个简单的示例，说明如何在选择上使用查找，并在完成后停止：

Sub WhereAreThey()
   Dim myRange As Range, valuee As String
   valuee = InputBox("Search String:")
   If valuee = vbNullString Then Exit Sub

   Range("A1").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Range(Selection, Selection.End(xlDown)).Select

   Set myRange = Selection.Find(what:=valuee, after:=Selection(1))
   If myRange Is Nothing Then
      MsgBox "no value"
      Exit Sub
   End If
   MsgBox myRange.Address(0, 0)
   st = myRange.Address(0, 0)

   Do Until myRange Is Nothing
      Set myRange = Selection.FindNext(after:=myRange)
      If myRange.Address(0, 0) = st Then Exit Do
      MsgBox myRange.Address(0, 0)
   Loop

   MsgBox "DONE"
End Sub

希望这对您有所帮助：）

将日期子移动到列（）
暗淡单元格作为范围
列（“A:A”）。选择
选择。插入Shift:=xlToRight，CopyOrigin:=xlFormatFromLeftOrAbove
范围（“G1”）。选择
范围（选择，选择。结束（xlDown））。选择
设置SelectedRange=Selection
Set FindDate=Selection.Find（内容：=“***/***/****”，查找：=xlFormulas）
“干到最后一刻什么都不是
“如果不是FindDate，那就什么都不是了
对于选定范围中的每个单元格
'Cell.Select
如果单元格的.Value为“”，则
Cells.Find（What:=“**/**/**”，After:=ActiveCell，LookIn:=xlFormulas，LookAt:=_
xlPart，SearchOrder:=xlByRows，SearchDirection:=xlNext，MatchCase:=False_
，SearchFormat:=False）。激活
ActiveCell，收到
ActiveCell.Offset（2，-7）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（2，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
ActiveCell.Offset（1，0）.粘贴特殊XLPasteValues和NumberFormats
'ActiveCell.Offest（1，0）。选择
如果结束
下一个细胞
End Sub

我建议您不要主动选择数据，而是移动到（1）查找顶行/左列和底行/右列，然后（2）根据预定义的限制循环该范围。这将有助于解决您的特定问题，但通常也是使用VBA编程的更好方法（避免。不惜一切代价选择，以提高速度并避免类似问题）。我以前从未编写过这样的代码。你能给我举个例子，我可以根据自己的需要修改吗？如何让excel知道您的代码没有编译的顶行/左列和底行/右列是什么。如果缺少，则会有一个明显的

结束。请修复您要编译的代码，并尝试更好地解释您想要实现的目标。例如，要复制并粘贴到同一工作表中，还是另一个工作表中？因为您的代码有时引用Sheet1，有时不引用。是的，它基本上会在每次出现日期时将日期添加到列a中。这将是将日期复制到同一张表中，只是复制到A列中。基本上，工作表是一系列连续出现的报告。每个报告的顶部都有一个日期，但我需要每个记录都有一个日期，这就是为什么此代码会获取显示在每张工作表顶部的日期，并将其放置在a列中每个记录的旁边。@JGoldz75查看如何避免的讨论。选择此处：
Sub Move_Dates_To_Column()
    Dim Cell As Range, selectedRange As Range, findDate As Range
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Set selectedRange = Range("G1:G10")
    Set Cell = selectedRange.Find(What:="**/**/****", After:=selectedRange.Cells(1, 1), LookIn:=xlFormulas)

    Columns(1).Insert
    Do Until Len(Cells(Cell.Row, 1).Text) > 0
        Cell.Copy
        Cells(Cell.Row, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Cell.Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Set Cell = selectedRange.FindNext(Cell)
    Loop
End Sub