Do до окончания кода выбора

Question

Я ищу, чтобы запустить цикл кодирования 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 

* Только примечание, есть пустые пространства во всем этом диапазоне. Диапазон должен быть "Range (G: G)"

Answer 1

Вот простой пример использования Найти над Выбором и остановок, когда сделано:

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 

Answer 2

Надеется, что это поможет :)

Sub Move_Dates_To_Column() 
 
Dim Cell As Range 
 
    Columns("A:A").Select 
 
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 
 
    Range("G1").Select 
 
    Range(Selection, Selection.End(xlDown)).Select 
 
Set SelectedRange = Selection 
 
Set FindDate = Selection.Find(What:="**/**/****", LookIn:=xlFormulas) 
 
' Do Until FindDate Is Nothing 
 
'   If Not FindDate Is Nothing Then 
 
For Each Cell In SelectedRange 
 
'Cell.Select 
 
If Cell.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

Answer 3

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