VBA求助：求同列相临最近的2个相等数之间的行距

xiashuming1

向大虾求助一个VBA程序，逻辑如下：  
求B2:E中同列相临最近的2个相等数之间的行距，返回到F2:I中，VBA循环执行到D列最后一个空值时停止。
非常感谢！！！

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    For j = UBound(arr) To 3 Step -1
        For i = 2 To 5
            If Len(arr(j, i)) > 0 Then
                For x = j - 1 To 2 Step -1
                    If arr(x, i) = arr(j, i) Then
                        arr(j, i + 4) = j - x - 1
                        Exit For
                    End If
                Next x
            End If
        Next i
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

附件内容供参考。。。。。。

xiashuming1

liulang0808 发表于 2020-2-12 08:11
附件内容供参考。。。。。。

你好，辛苦了，VBA实现了要求的功能，但就是运行时间久一些，是不是改成数组赋值会快很多，可以改吗，非常感谢

liulang0808

xiashuming1 发表于 2020-2-12 12:15
你好，辛苦了，VBA实现了要求的功能，但就是运行时间久一些，是不是改成数组赋值会快很多，可以改吗，非 ...

数据量大，自然会偏慢的
目前的代码是使用的数组，楼主的数组是指什么？

xiashuming1

liulang0808 发表于 2020-2-12 12:24
数据量大，自然会偏慢的
目前的代码是使用的数组，楼主的数组是指什么？

哦，好的，谢谢

lsdongjh

1. 
   
2. Sub Test()
   
3.     Dim sh As Worksheet, lngRow As Long, lngCol As Long
   
4.     Dim arr As Variant, objDic As Object, strKey As String, lngItem As Long
   
5.    
   
6.     Set sh = Sheets("6688")
   
7.     lngRow = sh.Range("B" & Rows.Count).End(xlUp).Row
   
8.    
   
9.     arr = sh.Range("B3:E" & lngRow)
   
10.     Set objDic = CreateObject("Scripting.Dictionary")
    
11.    
    
12.     For lngCol = LBound(arr, 2) To UBound(arr, 2)
    
13.         objDic.RemoveAll '按列
    
14.         For lngRow = LBound(arr) To UBound(arr)
    
15.             strKey = Trim(arr(lngRow, lngCol))
    
16.             If strKey <> "" Then
    
17.                 If objDic.Exists(strKey) Then
    
18.                     lngItem = lngRow - objDic(strKey) - 1
    
19.                     objDic(strKey) = lngRow
    
20.                     arr(lngRow, lngCol) = lngItem
    
21.                 Else
    
22.                     objDic(strKey) = lngRow
    
23.                     arr(lngRow, lngCol) = "" '首次出现
    
24.                 End If
    
25.             End If
    
26.         Next
    
27.     Next
    
28.    
    
29.     sh.Range("F3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
30.     Set objDic = Nothing
    
31.     MsgBox "OK"
    
32. End Sub

复制代码

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For j = UBound(arr) To 3 Step -1
        For i = 2 To 5
            If Len(arr(j, i)) > 0 Then
                If d.exists(i & "@@" & arr(j, i)) Then
                    arr(d(i & "@@" & arr(j, i)), i + 4) = d(i & "@@" & arr(j, i)) - j - 1
                    d(i & "@@" & arr(j, i)) = j
                Else
                    d(i & "@@" & arr(j, i)) = j
                End If
            End If
        Next i
    Next j
    [a1].CurrentRegion = arr
End Sub
这个修改了下，看看效率是否提升吧

liulang0808

看看是否有提升吧

xiashuming1

liulang0808 发表于 2020-2-12 13:09
看看是否有提升吧

哦，好的，谢谢，速度差不多