Функция поиска петли

Question

У меня есть этот код, который ищет Даты в большом тексте в нескольких ячейках (столбец A). Проблема в том, что иногда число дат может достигать 400! Я не могу повторить этот код для 400 значений!

Цель кода:

Find("Date d'Evaluation(1):"), copy/past in B5 (-22 car)
Find("Date d'Evaluation(2):"), copy/past in C5 (-22 car)
Find("Date d'Evaluation(3):"), copy/past in D5 (-22 car)
…
…

код:

Dim Date1 As Range
Dim Date2 As Range
Dim Date3 As Range

''''''' trouver les dates d'observation
Set Date1 = Worksheets("Sheet1").Range("A1:A500").Find("Date d'Evaluation(1):")
Worksheets("Sheet2").Range("B5").Value = Date1.Value
Worksheets("Sheet2").Range("B5").Value = Right(Date1.Value, Len(Date1.Value) - 22) 'enelve le surplu

Set Date2 = Worksheets("Sheet1").Range("A1:A500").Find("Date d'Evaluation(2):")
Worksheets("Sheet2").Range("C5").Value = Date2.Value
Worksheets("Sheet2").Range("C5").Value = Right(Date2.Value, Len(Date2.Value) - 22) 'enelve le surplu

Set Date3 = Worksheets("Sheet1").Range("A1:A500").Find("Date d'Evaluation(3):")
Worksheets("Sheet2").Range("D5").Value = Date3.Value
Worksheets("Sheet2").Range("D5").Value = Right(Date3.Value, Len(Date3.Value) - 22) 'enelve le surplu

После поиска в Google основные вопросы:

• Можно ли зациклить Dim Date(n) As range?
• Могу ли я зациклиться, пока он не найдет ("Date d'Evaluation (n):")? Тогда остановись петля ...

Answer 1

Вы можете сделать все в одном цикле. Цикл работает, пока ничего не найдено:

Option Explicit

Sub ProcedureName()
    Dim RangeToSearch As Range
    Set RangeToSearch = Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp))

    Dim i As Long
    i = 1
    Do
        Dim FoundRange As Range
        Set FoundRange = RangeToSearch.Find(What:="Date d'Evaluation(" & i & "):", LookAt:=xlPart)

        If Not FoundRange Is Nothing Then
            Dim FoundDate As Variant
            FoundDate = Split(Right$(FoundRange.Value, Len(FoundRange.Value) - 22), "/")

            Worksheets("Sheet2").Range("B5").Offset(ColumnOffset:=i - 1).Value = DateSerial(FoundDate(2), FoundDate(1), FoundDate(0))
        End If

        i = i + 1
    Loop Until FoundRange Is Nothing
End Sub

Обратите внимание, что в метод Find необходимо включить LookAt:=xlPart. В противном случае Excel использует метод, который последний раз использовался Excel (и вы никогда не знаете, какой это был).

Я использовал Split, чтобы разбить найденную дату, например, 02/04/2024 в массив:

FoundDate(0) = "02"
FoundDate(1) = "04"
FoundDate(2) = "2024"

чтобы мы могли преобразовать ее в реальную дату с помощью DateSerial

• DateSerial(FoundDate(2), FoundDate(1), FoundDate(0)) для DD/MM/YYYY
• DateSerial(FoundDate(2), FoundDate(0), FoundDate(1)) для MM/DD/YYYY

Answer 2

Хммм ... мой пост почти идентичен посту Пи. Ну что ж, я добавил пару поворотов.

LookAt:=xlPart необходим для поиска, будет искать частичные значения ячеек. Я использовал LookIn:=xlValues, потому что я построил свой набор данных, используя формулы.

Идея состоит в том, чтобы добавить все найденные значения в ArrayList и записать их обратно в Sheet2 за одну операцию.

Sub UpdateDEvaluation()
    Dim list As Object, Found As Range, Source As Range
    Dim n As Long

    With Worksheets("Sheet1")
        Set Source = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
    End With

    Set list = CreateObject("System.Collections.ArrayList")

    Do
        n = n + 1

        Set Found = Source.Find(What:="Date d'Evaluation(" & n & "):", LookAt:=xlPart, LookIn:=xlValues)

        If Not Found Is Nothing Then
            list.Add Right(Found.Value, Len(Found.Value) - 22)
        End If

    Loop Until Found Is Nothing

    If list.Count > 0 Then
        Worksheets("Sheet2").Range("D5").Resize(1, list.Count).Value = list.ToArray
    End If

End Sub

Answer 3

Как насчет следующего, он будет зацикливаться до 400 раз и останавливать зацикливание, когда ничего не найдено:

Sub foo()
Dim Date1 As Range
For i = 1 To 400
    FindValue = "Date d'Evaluation(" & i & "):"
''''''' trouver les dates d'observation
    Set Date1 = Worksheets("Sheet1").Range("A1:A500").Find(What:=FindValue, LookAt:=xlPart)
    If Not Date1 Is Nothing Then
        Worksheets("Sheet2").Cells(5, i + 1).Value = Right(Date1.Value, Len(Date1.Value) - 22) 'enelve le surplu
    Else
        Exit For
    End If
Next i
End Sub