求各行相邻二个黄色单元格所形成的最小区间的数据个数的vba程序

CAONI

1、在区间b3:k5000的各单元格中分别填有不同的数字，且有的单元格被填上黄色颜色以作标记。
2、各行以黄色单元格作分隔标记，将各行分成几个数字区间，区间数字不包括黄色单元格数据，二个相邻黄色单元格为一个区间。
3、依次求各行最小区间中的数据个数分别提取到m3开始的m列。
4、例如：B3:K3行相邻二个黄色单元格所形成的区间有c3:e3和e3：h3二个区间，其中为c3:e3最小区间，求出c3:e3区间中数据个数1个填在m3开始的m列。
5、B6:K6行相邻二个黄色单元格所形成的区间有c6:d6、d6:f6、f6:g6三个区间，其中c6:d6最小区间，求出c6:d6区间中数据个数0个填在m列、依次。
谢谢！！！

求区间数字个数.zip (15.64 KB, 下载次数: 13)

2020-5-31 14:45 上传

点击文件名下载附件

vic9

Sub j()
Dim i, r, j%, Arr1, m, n
Arr1 = Sheets("sheet1").Range("A1:M5000")
ReDim arr2(1 To 1, 1 To UBound(Arr1) - 2)
For i = 3 To UBound(Arr1)
If Len(Arr1(i, 2)) > 0 Then
n = UBound(Arr1, 2)
    For r = 2 To UBound(Arr1, 2) - 2
        With Sheets("sheet1")
        
            If .Cells(i, r).Interior.ColorIndex = 6 Then
                j = j + 1
                arr2(1, j) = r
                If j > 1 Then
                    m = arr2(1, j) - arr2(1, j - 1) - 1
                    n = Application.Min(n, m)
                End If
            End If
        End With
    Next
    If j <= 1 Then
        Arr1(i, 13) = "没有符合要求的数据"
    Else
        Arr1(i, 13) = n
    End If
        j = 0
        m = 0
    End If
Next
Sheets("sheet1").[a1].Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
End Sub

风筝那根线

关注一下，学习下算法

一把小刀闯天下

vic9

Sub j()
Dim i, r, j%, Arr1, m, n
Arr1 = Sheets("sheet1").Range("A1:M5000")
ReDim arr2(1 To 1, 1 To UBound(Arr1) - 2)
For i = 3 To UBound(Arr1)
If Len(Arr1(i, 2)) > 0 Then
n = UBound(Arr1, 2)
    For r = 2 To UBound(Arr1, 2) - 2
        With Sheets("sheet1")
            If .Cells(i, r).Interior.ColorIndex = 6 Then
                j = j + 1
                arr2(1, j) = r
                If j > 1 Then
                    m = arr2(1, j) - arr2(1, j - 1) - 1
                    n = Application.Min(n, m)
                End If
            End If
        End With
    Next
    If j <= 1 Then
        Arr1(i, 13) = "没有符合要求的数据"
    Else
        Arr1(i, 13) = n
    End If
        j = 0
        m = 0
    End If
Next
Sheets("sheet1").[a1].Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
End Sub

CAONI

一把小刀闯天下 发表于 2020-5-31 20:19

老师你好，程序经测试满足要求，太强大了，谢谢！！！

CAONI

vic9 发表于 2020-5-31 20:22
Sub j()
Dim i, r, j%, Arr1, m, n
Arr1 = Sheets("sheet1").Range("A1:M5000")

老师你好，程序经测试满足要求，谢谢！！！

CAONI

vic9 发表于 2020-5-31 20:22
Sub j()
Dim i, r, j%, Arr1, m, n
Arr1 = Sheets("sheet1").Range("A1:M5000")

老师你好    把Arr1 = Sheets("sheet1").Range("A1:M5000")改成题意的数据区域： Arr1 = Range("b3:k5000")程序能修改吗，谢谢！！！