Loop Find function

user_6573951 0
Viewed 80

I have this code who is searching Dates in big text in severals cells (Column A). The probleme is that sometimes the number of dates can reach 400 !! I can't repeat this code for 400 values !

The aim of the code is :

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)
…
…

the code is :

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

After searching on google, the mains questions are:

  • Can I loop Dim Date(n) As range ?
  • Can I loop until it don't find ("Date d'Evaluation(n):") ? Then stop the loop...
excel-2016 vba excel
3 Answers

You can do all in one loop. The loop runs until nothing is found:

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

Note that it is necessary to include LookAt:=xlPart in the Find method. Otherwise Excel uses the method that was last used by Excel (and you never know which one this was).

I used Split to split the found date eg 02/04/2024 into an array:

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

so we can convert it into a real date with DateSerial

  • DateSerial(FoundDate(2), FoundDate(1), FoundDate(0)) for DD/MM/YYYY
  • DateSerial(FoundDate(2), FoundDate(0), FoundDate(1)) for MM/DD/YYYY
user_32196130

Hmmm...my post is almost identical to Pᴇʜ's. Oh well, I did add a couple of twists.

LookAt:=xlPart is needed so that find will search partial values of the cells. I used LookIn:=xlValues because I constructed my dataset using formulas.

The idea is to add all the found values to an ArrayList and write them back to Sheet2 in one operation. 

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
user_99127140

How about the following, it will loop up to 400 times, and stop looping when nothing is found:

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
user_86703720
Related