☰

计算表中两个相同值之间的距离（行）

tag-icon • tag-icon microsoft-excel vba
计算表中两个相同值之间的距离（行）

我有一个 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

答案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

答案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

相关内容