比较辣手的问题（没基准跨时间段提取数据）

lg747699

具体参考附件

半百

试试
Sub TEST()
Dim BRR(1 To 999, 1 To 3)
Set D = CreateObject("Scripting.Dictionary")
ARR = Range("A2").CurrentRegion
For I = 2 To UBound(ARR)
    If Not D.EXISTS(ARR(I, 2)) Then
        D(ARR(I, 2)) = ARR(I, 1)
    Else
        If ARR(I, 1) > D(ARR(I, 2)) Then
            If DateDiff("M", D(ARR(I, 2)), ARR(I, 1)) >= 6 Then
                N = N + 1
                BRR(N, 1) = D(ARR(I, 2))
                BRR(N, 2) = ARR(I, 1)
                BRR(N, 3) = ARR(I, 2)
            End If
            D(ARR(I, 2)) = ARR(I, 1)
        End If
    End If
Next
Range("G3").Resize(N, 3) = BRR
End Sub

lg747699

Sub TEST()
Dim BRR(1 To 999, 1 To 3)
Set D = CreateObject("Scripting.Dictionary")
ARR = Range("A2").CurrentRegion
For I = 2 To UBound(ARR)
    If Not D.EXISTS(ARR(I, 2)) Then
        D(ARR(I, 2)) = ARR(I, 1)
    Else
        If ARR(I, 1) > D(ARR(I, 2)) Then
            If DateDiff("M", D(ARR(I, 2)), ARR(I, 1)) >= 6 Then
                N = N + 1
                BRR(N, 1) = D(ARR(I, 2))
                BRR(N, 2) = ARR(I, 1)
                BRR(N, 3) = ARR(I, 2)
            End If
            D(ARR(I, 2)) = ARR(I, 1)
        End If
        If ARR(I, 1) < D(ARR(I, 2)) Then
            If DateDiff("M", D(ARR(I, 2)), ARR(I, 1)) <= -6 Then
                N = N + 1
                BRR(N, 1) = D(ARR(I, 2))
                BRR(N, 2) = ARR(I, 1)
                BRR(N, 3) = ARR(I, 2)
            End If
            D(ARR(I, 2)) = ARR(I, 1)
        End If
    End If
Next
Range("g3:i4000").ClearContents
Range("G3").Resize(N, 3) = BRR
End Sub
我在老师基础上，修改一下，因为时间未必是按顺序来的。