Excel VBA，每组捕获第一个“开始”值和最后“结束”值

Question

使用Excel VBA，我试图捕获每个组中“Start”列中的第一个值和“End”列中的最后一个值。数据已经排序。例：

我想捕获Start_open的第一个值和每个公司的Start_end的最后一个值。因此对于公司A代码应该将B2放在Start_Open中并将C5放在Start_end中。

使用此代码捕获最后一个值可以正常工作：

Sub First_last()

Dim i, j As Integer
Dim LastRow, LastCol As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column


For i = 2 To LastRow
    If Cells(i + 1, "A").Value <> Cells(i, "A").Value Then
        MsgBox i
        Cells(j + 2, "E").Value = Cells(i, "C").Value
        j = j + 1
    End If
Next

End Sub

我正在努力的是每组捕获Start_open。我想我需要使用上述条件并使用计数器来捕获每组的Start_open但我找不到合适的代码。请指教，谢谢！

Answer 1

您可以使用变量a和b来查找每个部分的开头和结尾：

 Dim a as Long, b as Long, i as Long, lr as Long
 lr = cells(rows.count,1).end(xlup).row
 For i = 2 to lr
     If cells(i,1).value = cells(i+1,1).value then
          If a = 0 then
              a = i + 1
          End If
     Else
          If a > 0 AND b = 0 then
              b = i + 1
          End If             
     End If
     If b > 0 AND a > 0 Then
         'perform max(range(cells(a,2),cells(b,2))), etc.
         a = 0 'resets for next grouping
         b = 0 'resets for next grouping
    End If
Next i
a = 0
b = 0

Answer 2

添加另一种方法。

Sub x()

Dim r As Range, oDic As Object, r1 As Range, r2 As Range, r3 As Range, v(), i As Long

Set oDic = CreateObject("Scripting.Dictionary")
Set r = Range("A2", Range("A" & Rows.Count).End(xlUp))
ReDim v(1 To r.Count, 1 To 3)

For Each r3 In r
    If Not oDic.Exists(r3.Text) Then
        Set r1 = r.Find(What:=r3, After:=r(r.Count), LookAt:=xlWhole, _
                        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        Set r2 = r.Find(r3, r(1), , , , xlPrevious)
        i = i + 1
        v(i, 1) = r3
        v(i, 2) = r1.Offset(, 1).Value
        v(i, 3) = r2.Offset(, 2).Value
        oDic.Add r3.Text, Nothing
    End If
Next r3

Range("D2").Resize(oDic.Count, 3) = v

End Sub

Answer 3

这将做你想要的：

Sub First_Last()
    With ActiveSheet
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Dim numUnique
        numUnique = .Evaluate("SUM(1/COUNTIF(A:A,A2:A" & LastRow & "))")

        Dim outarr As Variant
        ReDim outarr(1 To numUnique, 1 To 2)

        Dim clmc As Variant
        clmc = .Range(.Cells(1, 3), .Cells(LastRow, 3)).Value

        Dim clmb As Variant
        clmb = .Range(.Cells(1, 2), .Cells(LastRow, 2)).Value

        Dim j As Long
        j = 1

        Dim i As Long
        For i = 2 To LastRow
            outarr(j, 1) = clmb(i, 1)
            Dim k As Long
            k = .Evaluate("AGGREGATE(14,6,ROW(A2:A" & LastRow & ")/(A2:A" & LastRow & " = " & .Cells(i, 1).Address & "),1)")
            outarr(j, 2) = clmc(k, 1)
            j = j + 1
            i = k
        Next i

        .Range("D2").Resize(UBound(outarr, 1), UBound(outarr, 2)).Value = outarr
    End With
End Sub