循环查找功能

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

下面这样呢，最多循环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

Answer 2

您可以在一个循环中完成所有操作。循环运行直到什么都找不到：

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 3

嗯...我的 post 几乎与 Pᴇʜ 的相同。哦，好吧，我确实添加了一些曲折。

需要

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

循环查找功能

Loop Find function

excel

vba

excel-2016