Вычисление расстояния (строк) между двумя одинаковыми значениями в таблице

Question

У меня есть код VBA для расчета расстояния между двумя ячейками с одинаковыми значениями в таблице. Мне просто нужна разница строк между ячейками, которые могут находиться в разных столбцах, как показано на рисунке. Мне нужно только расстояние по оси "Y", а не по оси "X". У этого кода есть функциональность и дизайн, которые мне нужны, но он также рассчитывает расстояние по оси "X".

На приведенном ниже примере изображения в столбце B B5: Центральное соответствует ближайшему (внизу). B12: Центральное, а расстояние (количество строк между ними) равно 6. А в E1: 250 он совпадает с ближайшим G16: 250, а расстояние составляет 13.

У меня есть код:

Option Explicit

Sub main()
    Dim cell As Range, f As Range
    Dim rowOffset As Long

    With Worksheets("gaps").Range("A2:F10") '<--| change this to your actual range of interest
        For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers)
            rowOffset = 1
            Set f = .Find(what:=cell, after:=cell, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
            If Not f Is Nothing And f.Row <= cell.Row Then rowOffset = cell.Row - f.Row + 1
            cell.offset(, .Columns.Count + 1) = rowOffset '<--| the "+1" offset results range one column away from values range: adjust it as per your needs
        Next cell
    End With
End Sub

Answer 1

Вычислить строки

Sub main4()
Dim cell As Range, f As Range
Dim RowOffset As String
With Worksheets("gaps").Range("A2:F10") '<--| change this to your actual range of interest
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers)
        RowOffset = "na"
        Set f = .Find(what:=cell, after:=cell, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
        If (f.Row <> cell.Row) Or (f.Row <> cell.Row) Then RowOffset = f.Row - cell.Row
        cell.Offset(, .Columns.Count + 1) = RowOffset '<--| the "+1" offset results range one Row away from values range: adjust it as per your needs
    Next cell
End With
End Sub

вычислять столбцы

Sub main2()
Dim cell As Range, f As Range
Dim ColOffset As String
With Worksheets("gaps").Range("A2:F10") '<--| change this to your actual range of interest
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers)
        ColOffset = "na"
        Set f = .Find(what:=cell, after:=cell, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
        If (f.Column <> cell.Column) Or (f.Row <> cell.Row) Then ColOffset = f.Column - cell.Column
        cell.Offset(, .Columns.Count + 1) = ColOffset '<--| the "+1" offset results range one column away from values range: adjust it as per your needs
    Next cell
End With
End Sub

Или, что еще лучше, вы можете указать строку и столбец в ячейке:

Sub main3()
Dim cell As Range, f As Range
Dim Offset As String

With Worksheets("gaps").Range("A2:F10") '<--| change this to your actual range of interest
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers)
        Offset = "na"
        Set f = .Find(what:=cell, after:=cell, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
        If (f.Column <> cell.Column) Or (f.Row <> cell.Row) Then Offset = (f.Column - cell.Column) & ";" & (f.Row - cell.Row)
        cell.Offset(, .Columns.Count + 1) = Offset '<--| the "+1" offset results range one column away from values range: adjust it as per your needs
    Next cell
End With
End Sub

Answer 2

Вот решение, которое я нашел для этой проблемы, решая проблемы, которые у меня были в предложенных кодах.

Sub Intervals()
    Dim r As Range, c As Range
    With Cells(1).CurrentRegion
        With .Offset(1).Resize(.Rows.Count - 1)
            For Each r In .Cells
                Set c = .Find(r.Value, r, , 1, , , 2)
                If (c.Address <> r.Address) * (c.Row > r.Row) Then
                    r.Offset(, 13) = c.Row - r.Row - 1
                Else
                    r.Offset(, 13) = "na"
                End If
            Next
        End With
    End With
End Sub