[已解决]请教老师：向上查找出现相同数的行数

lygyjt

请教老师：
    A列是序号，不参与计算。计算数据是从B列开始，行列都是变量。
    任意一行，在它上面第1列里，由下向上查找，当此行任意一个数据，在此列最先出现时，将这个位置记录在此行后面第1个空格里；在它上面第2列里，由下向上查找，当此行任意一个数据，在此列最先出现时，将这个位置记录在此行后面第2个空格里。以此类推
    比如：序号为15这行，它上面第1列，就是指“B1:B14”；由下向上查找，是指由B14向B1查找； 此行任意一个数据，是指55、58、70、75、77、84、85、56任意一个；在此列最先出现，是指此行有2个数据58和56，出现在由B14向B1查找中，但58这个数是最先出现的，它是由B14开始，向上查到第10个就出现了，而56这个数，是在向上查到第14个时才出现的，所以，将10记录在J15的位置。同理，在序号为15这行，它上面第2列，即“C1:C14”由下向上查找中，56这个数最先出现，所以，将1记录在K15的位置。以此类推。
    没有找到的，记录为0；第1行不需要找，因为它上面没有列，不符合条件。
    红字为此行的标准答案。 向上查找出现相同数的行数.rar (9.73 KB, 下载次数: 9)

2020-9-17 09:02 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

POS寻找

2020-9-17 09:02

修改前
Sub chazhao()

Dim wb As Workbook, last%, arr, x%, y%, d, s, a As Date, b As Date
Application.ScreenUpdating = False
a = Time
Set wb = ThisWorkbook
Set d = CreateObject("scripting.dictionary")
last = wb.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row

With wb.Sheets(1)
    For i = 2 To last
   
        For j = 2 To 9
            d.Add .Cells(i, j).Value, j
        Next j
        
        For j = 2 To 9
            For m = i - 1 To 1 Step -1
                s = .Cells(m, j)
                If d.Exists(s) Then
                    .Cells(i, j + 8) = i - m
                    Exit For
                End If
            Next m
            If .Cells(i, j + 8) = "" Then .Cells(i, j + 8) = 0
        Next j
        d.RemoveAll
    Next i
End With
b = Time - a
Application.ScreenUpdating = False
MsgBox "查找完毕，用时：" & b
End Sub
其他老师修改后：
Sub tst()
Dim arr, brr, d As Object
Range("J1:Q" & [A65536].End(xlUp).Row + 1).ClearContents
Set d = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        d(arr(i, j)) = ""
    Next
    For j = 2 To UBound(arr, 2)
        For k = i - 1 To 1 Step -1
            If d.exists(arr(k, j)) Then
                brr(i, j - 1) = i - k
                Exit For
            else
                brr(i, j - 1) =0
            End If
        Next
    Next
    d.RemoveAll
Next
[J1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

跳转到最佳答案楼层

POS寻找

修改前
Sub chazhao()

Dim wb As Workbook, last%, arr, x%, y%, d, s, a As Date, b As Date
Application.ScreenUpdating = False
a = Time
Set wb = ThisWorkbook
Set d = CreateObject("scripting.dictionary")
last = wb.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row

With wb.Sheets(1)
    For i = 2 To last
   
        For j = 2 To 9
            d.Add .Cells(i, j).Value, j
        Next j
        
        For j = 2 To 9
            For m = i - 1 To 1 Step -1
                s = .Cells(m, j)
                If d.Exists(s) Then
                    .Cells(i, j + 8) = i - m
                    Exit For
                End If
            Next m
            If .Cells(i, j + 8) = "" Then .Cells(i, j + 8) = 0
        Next j
        d.RemoveAll
    Next i
End With
b = Time - a
Application.ScreenUpdating = False
MsgBox "查找完毕，用时：" & b
End Sub
其他老师修改后：
Sub tst()
Dim arr, brr, d As Object
Range("J1:Q" & [A65536].End(xlUp).Row + 1).ClearContents
Set d = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        d(arr(i, j)) = ""
    Next
    For j = 2 To UBound(arr, 2)
        For k = i - 1 To 1 Step -1
            If d.exists(arr(k, j)) Then
                brr(i, j - 1) = i - k
                Exit For
            else
                brr(i, j - 1) =0
            End If
        Next
    Next
    d.RemoveAll
Next
[J1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

lygyjt

POS寻找 发表于 2020-9-17 09:02
修改前
Sub chazhao()

谢谢老师的指教！希望还能得到您的帮助。

hcm19522

J2:Q2 下拉{=ROW()-TEXT(MAX(COUNTIF($B2:$I2,B$1:B1)*ROW($1:1)),"0;;"&ROW())

lygyjt

hcm19522 发表于 2020-9-20 14:49
J2:Q2 下拉{=ROW()-TEXT(MAX(COUNTIF($B2:$I2,B$1:B1)*ROW($1:1)),"0;;"&ROW())

谢谢老师的指教!无奈行数太多，用函数计算较慢了。盼望日后继续能得到老师您的支持和帮助！