Question

我想遍历数组并提取与范围内每个日期匹配的定界值。例如，在下面的图片中：

我有一个日期范围，例如01-01至01-10。
我还有一个字符串列表（请参见第二张图片）。
在下面的数组中（请参见第一个图片），我有三个不同的值，以分号分隔。
对于所有匹配的字符串（从第二张图片开始），例如SISBTXTRPR-（数字）和日期，我想提取数组值的最后一部分。

图片1

图片2

因此，对于与“ SISBTXTRPR-4649”（图2中的字符串）和日期（在这种情况下为12-12）匹配的所有数组值，我想从数组中提取“ 2h”。每个字符串的日期范围（在这种情况下为“ SISBTXTRPR-4649”）将为10天。我全神贯注于如何做到这一点：（

到目前为止，这是我所能想到的：

While i < UBound(sTimeStamp)
If StrComp(Trim(Format(Now(), "MM-DD")), Trim(Split(sTimeStamp(9), ";")(1))) = 0 And StrComp(Trim(Worksheets("KPIs").Range("AN" & iCounter)), Trim(Split(sTimeStamp(1), ";")(0))) Then

End If
i = i + 1
Wend

链接到文件

Sample File

Answer 1

下一个代码将返回“任务”范围内的每个字符串的匹配项，这些字符串匹配其对应的“ sTimeStamp数组”字符串中的日期与“日期范围数组”中的字符串。每次出现都会添加到“任务”字符串列的下一列：

Private Sub findOccurrences()
  Dim sTask As Worksheet, sStamp As Worksheet, sDate As Worksheet
  Dim arrTask As Variant, arrStamp As Variant, arrDate As Variant
  Dim i As Long, j As Long, arrS As Variant, El As Variant, dtRef As Date

  Set sTask = ThisWorkbook.Sheets("Task")
  Set sStamp = ThisWorkbook.Sheets("sTimeStamp Array")
  Set sDate = ThisWorkbook.Sheets("Date Range Array")
    arrTask = sTask.Range("A2:A" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Value
    arrStamp = sStamp.Range("A2:A" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Value
    arrDate = sDate.Range("A2:A" & sDate.Range("A" & sDate.Rows.Count).End(xlUp).Row).Value

    '____________________________________________________________________________  
    sTask.Range("B2:K" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Clear  
    Do While i < UBound(arrStamp)
        i = i + 1
        arrS = Split(arrStamp(i, 1), ";")
        For j = 1 To UBound(arrTask)
            If arrS(0) = arrTask(j, 1) Then
                For Each El In arrDate
                    dtRef = DateValue(Format(El, "MM-DD"))
                    If dtRef = DateValue(Format(arrS(1), "MM-DD")) Then
                        Debug.Print arrS(0) & " (row number " & j + 1 & "), interval """ & _
                                                                        El & """ exists."
                        sTask.Cells(j + 1, sTask.Cells(j + 1, _
                            sTask.Columns.Count).End(xlToLeft).Column).Offset(0, 1).Value = El
                    End If
                Next
            End If
        Next j
    Loop

End Sub

简短变体的工作方式与您的方法类似，查找“今日”日期的出现（如果我正确推断出您打算实现的目标），请用以下内容替换循环部分：

'______________________________________________________________________________
    sStamp.Range("B2:B" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Clear
sTask.Range("A2:A" & sTask.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Interior.ColorIndex = -4142
While i < UBound(arrStamp)
    i = i + 1
    If StrComp(DateValue(Format(Date, "MM-DD")), DateValue(Split(arrStamp(i, 1), ";")(1))) = 0 And _
                                Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(1)), arrDate) Then
        Debug.Print "OK for """ & Split(arrStamp(i, 1), ";")(0) & """ of row """ & i & """."
        sStamp.Range("B" & i + 1).Value = "OK"
        If Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(0)), arrTask) Then
            rowOK = WorksheetFunction.Match(Split(arrStamp(i, 1), ";")(0), arrTask, 0) + 1
            sTask.Range("A" & rowOK).Interior.ColorIndex = 3
        End If
    End If
Wend

并添加下一个功能：

Function isMatchErr(strTime As String, arrDate As Variant) As Boolean
   Dim k As Long
   On Error Resume Next
     k = WorksheetFunction.Match(strTime, arrDate, 0)
     If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0: isMatchErr = True
     End If
   On Error GoTo 0
End Function

除了“即时窗口”中的消息外，所有出现的事件（在“ sTimeStamp Array”工作表中）的B：B列上都将显示“ OK”，并且匹配单元格的背景（在“ Task”工作表中将被涂成红色为了做到这一点，我添加了一条新记录并修改了“ Today”（“ 01-12”）的现有单元格，请执行相同的操作，以便至少在B：B列中获得两个结果。

请确认这就是您想要的。如果没有，请更好地说明需要...

满足条件时遍历数组元素并提取定界值

1 个答案: