求个代码

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    arr = sht.[b1:ao369]
    ReDim brr(1 To 100, 1 To 100)
    n = 0
    For j = 2 To UBound(arr, 2) Step 2
        n = n + 1: x = 2
        brr(n, 1) = arr(1, j - 1)
        For i = 2 To UBound(arr)
            If arr(i, j) = "偶" Then
                m = m + 1
            Else
                If m > 3 Then brr(n, x) = m: y = Application.Max(x, y): x = x + 1
                m = 0
            End If
        Next
    Next
    sht.[ar2].CurrentRegion.Offset(1).ClearContents
    sht.[ar2].Resize(n, y) = brr
    Beep
End Sub

wenping998

quqiyuan 发表于 2024-10-17 14:50
参与一下，仅供参考。。。

这个代码如果我要找含3个以上的 或者找4个奇以上的 怎么改代码呢

quqiyuan

这是两个问题，
3个或以上

改成获取奇

你测试一下咯

wenping998

quqiyuan 发表于 2024-10-17 17:40
这是两个问题，
3个或以上

太厉害了  感谢感谢

wenping998

quqiyuan 发表于 2024-10-17 17:40
这是两个问题，
3个或以上

哥 又弄了个表格 麻烦您抽空帮我再看看  辛苦您了

quqiyuan

wenping998 发表于 2024-10-24 11:19
哥 又弄了个表格 麻烦您抽空帮我再看看  辛苦您了

供你参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    r = sht.Cells(Rows.Count, 2).End(3).Row
    arr = sht.Range(sht.[b2], Cells(r, "g"))
    ReDim brr(1 To 10000, 1 To 3)
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        For j = 2 To UBound(arr, 2)
            f = 0
            Set Rng = sht.Cells(i + 1, j + 1)
            For k = 1 To Len(Rng.Value)
                If Rng.Characters(k, 1).Font.ColorIndex = 3 Then f = 1: Exit For
            Next
            ss = arr(1, j)
            n = n + 1
            brr(n, 1) = s
            brr(n, 2) = ss
            If n > 5 Then
                If f = 1 Then
                    brr(n, 3) = brr(n - 5, 3) + 1
                Else
                    brr(n, 3) = brr(n - 5, 3) + 0
                End If
            Else
                If f = 1 Then
                    brr(n, 3) = 1
                Else
                    brr(n, 3) = 0
                End If
            End If
        Next
    Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With sht
        .[u3].CurrentRegion.Clear
        .[u3].Resize(n, 3) = brr
        .[u3].CurrentRegion.Borders.LineStyle = 1
        .[u3].CurrentRegion.HorizontalAlignment = xlCenter
        For i = n To 1 Step -1
            If .Cells(i + 2, "u") = .Cells(i + 1, "u") Then .Cells(i + 1, "u").Resize(2).Merge
        Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

wenping998

quqiyuan 发表于 2024-10-24 13:26
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

完美解决 优秀

wenping998

quqiyuan 发表于 2024-10-24 13:26
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

大哥 又弄了个表格 麻烦给弄个代码  又给你添麻烦了 详见附件

quqiyuan

wenping998 发表于 2024-11-4 17:49
大哥 又弄了个表格 麻烦给弄个代码  又给你添麻烦了 详见附件

你这个一开始开得头大，不明白，后来嘛，还是大概看懂了，仅供参考。。。