求个代码

wenping998

quqiyuan 发表于 2024-11-9 12:40
代码如下。。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

不错 给解决了  省很多时间  后面的数据我整理下

wenping998

quqiyuan 发表于 2024-11-9 12:40
代码如下。。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

大哥 刚出了个表格 有4个sheet 都需要计算 给个代码支持 要求和详情都是表格附件里 帮我看看 麻烦您了

quqiyuan

wenping998 发表于 2025-1-13 15:53
大哥 刚出了个表格 有4个sheet 都需要计算 给个代码支持 要求和详情都是表格附件里 帮我看看 麻烦您了

参与一下，仅供参考。。。

quqiyuan

代码如下，，，
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    arr = sht.[a1].Resize(r, 8)
    s = sht.[n1]
    s1 = --Left(s, 1): s2 = --Right(s, 1)
    ReDim brr(1 To UBound(arr), 1)
    brr(1, 0) = 1
    n = 1
    For i = 2 To UBound(arr) - 1
        If arr(i, 3 + s1) <> Empty And arr(i + 1, 3 + s2) <> Empty Then
            n = n + 1
            brr(n, 0) = arr(i, 1)
            brr(n, 1) = brr(n, 0) - brr(n - 1, 0) - 1
        End If
    Next
    sht.[k1].CurrentRegion.Offset(1).ClearContents
    sht.[k2].Resize(n, 2) = brr
    Beep
End Sub