Do Until End of Selection code

Question

I'm looking to run an Excel VBA looping code that searches through column 'G' searching for any dates that appears, and then does something with that date, and then moves on to the next date that appears in the selection. My problem is that once the code reaches the bottom of the worksheet (or the end of the selection), it just restarts back at the top of the section and loops all over again. I need the code to stop once it reaches the end of the document (and in this case, the end of the selection). Any ideas on how to accomplish this?

Here is my code so far:

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

*Just a note, there are blank spaces throughout this range. The range should be "Range(G:G)"

Instead of actively selecting the data, I recommend you move to (1) find the top row / left column and bottom row / right column, and then (2) Loop through that range based on pre-defined limits. This will help with your specific problem but is also generally the better way to program in VBA (avoid .Select at all costs, for speed and to avoid problems like this). — Grade 'Eh' Bacon, Oct 09 '15 at 16:02
I have never coded like this before. Can you give me an example that I can alter to fit my needs? How would I let excel know what the top row/left column is and bottom row / right column — JGoldz75, Oct 09 '15 at 16:10
Your code does not compile. There is an obvious `End If` missing. Please fix your code to compile and try to explain better what you want to achieve. For instance, do you want to copy and paste in the same worksheet, or another one? because your code sometimes references Sheet1 and sometimes does not. — A.S.H, Oct 09 '15 at 16:16
Yes it basically adds a date into column A every time a date appears. It would be copying the dates into the same sheet, just into column A. Basically, the worksheet is a whole bunch of reports thats appear one after another. Each report has a date on the top, but I need every record to have a date, which is why this code grabs the date that appears at the top of each sheet and places it next to each record in column A. — JGoldz75, Oct 09 '15 at 16:23
@JGoldz75 See a discussion of how to avoid .Select here: http://stackoverflow.com/q/10714251/5090027 — Grade 'Eh' Bacon, Oct 09 '15 at 16:44

score 0 · Answer 1 · answered Oct 09 '15 at 16:30

Here is a simple example of using Find over a Selection and stopping when done:

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

score 0 · Answer 2 · answered Oct 09 '15 at 16:47

Hope this will help you :)

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

A.S.H · Answer 3 · 2015-10-09T17:05:53.657

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

Do Until End of Selection code

3 Answers3