Menghitung jarak (baris) antara dua nilai yang sama di atas meja

Saya memiliki Kode VBA untuk menghitung jarak antara dua sel dengan nilai yang sama di atas meja. Saya hanya perlu perbedaan baris antara sel-sel yang dapat pada kolom yang berbeda seperti yang terlihat pada gambar. Saya hanya perlu jarak pada sumbu "Y", bukan pada sumbu "X". Kode ini memiliki fungsi dan desain yang saya butuhkan tetapi juga menghitung jarak pada sumbu "X".

Pada contoh gambar di bawah ini, di kolom B, B5: Tengah cocok dengan yang terdekat (turun) B12: Tengah , dan jarak (jumlah baris di antara mereka) adalah 6. Dan dalam E1: 250 itu cocok dengan paling dekat G16: 250 , dan jaraknya 13.

Kode yang saya miliki adalah ini:

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

Hitung barisnya

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

menghitung kolom

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

Atau bahkan lebih baik, Anda dapat menunjukkan baris dan kolom di sel:

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

Berikut adalah solusi yang saya temukan untuk masalah ini dalam mengatasi masalah yang saya miliki dalam kode yang ditawarkan.

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