Сделать до конца кода выбора

Я хочу запустить код цикла 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)».


loops excel vba do-while
person JGoldz75    schedule 09.10.2015    source источник
comment
Вместо активного выбора данных я рекомендую перейти к (1) поиску верхней строки / левого столбца и нижней строки / правого столбца, а затем (2) прокрутки этого диапазона на основе заранее определенных пределов. Это поможет с вашей конкретной проблемой, но также, как правило, является лучшим способом программирования на VBA (избегайте .Select любой ценой, для скорости и во избежание подобных проблем).   -  person Grade 'Eh' Bacon    schedule 09.10.2015
comment
Я никогда раньше так не программировал. Вы можете привести мне пример, который я могу изменить в соответствии со своими потребностями? Как я могу сообщить excel, что такое верхняя строка / левый столбец и нижняя строка / правый столбец   -  person JGoldz75    schedule 09.10.2015
comment
Ваш код не компилируется. Здесь явно отсутствует End If. Пожалуйста, исправьте свой код для компиляции и попытайтесь лучше объяснить, чего вы хотите достичь. Например, вы хотите скопировать и вставить тот же лист или другой? потому что ваш код иногда ссылается на Sheet1, а иногда нет.   -  person A.S.H    schedule 09.10.2015
comment
Да, он в основном добавляет дату в столбец A каждый раз, когда появляется дата. Это будет копирование дат на тот же лист, только в столбец A. По сути, рабочий лист представляет собой целую группу отчетов, которые появляются один за другим. У каждого отчета есть дата вверху, но мне нужно, чтобы у каждой записи была дата, поэтому этот код захватывает дату, которая появляется вверху каждого листа, и помещает ее рядом с каждой записью в столбце A.   -  person JGoldz75    schedule 09.10.2015
comment
@ JGoldz75 См. Обсуждение того, как этого избежать. Выберите здесь: stackoverflow.com/q/10714251/5090027   -  person Grade 'Eh' Bacon    schedule 09.10.2015

Ответы (2)


arrow_upward
0
arrow_downward

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

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
person Gary's Student    schedule 09.10.2015

arrow_upward
0
arrow_downward

Надеюсь, что это поможет вам :)

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

person Linga    schedule 09.10.2015