[已解决]请看附件要求，如何写代码。

tting

XgN7i2Au.rar (7.33 KB, 下载次数: 11)

2010-8-23 13:44 上传

点击文件名下载附件
请看附件要求，如何写代码。
请看附件要求，如何写代码。

最佳答案

月排行榜 / 总排行榜

amulee

2010-8-23 14:13

Sub Test()
    Dim Rng As Range
    Dim i&, j%, k%
    Dim iStart&, iEnd&
    Set Rng = Range("A1:C" & Range("A" & Cells.Rows.Count).End(xlUp).Row)
    Range("F52:IV54").Clear
    For j = 1 To 3
        k = 5
        iStart = 0
        For i = Range("A" & Cells.Rows.Count).End(xlUp).Row To 1 Step -1
            If Rng(i, j).Interior.ColorIndex = 3 Then
                iEnd = Rng(i, j).Row
                If iStart > 0 Then
                    k = k + 1
                    Cells(51 + j, k) = iStart - iEnd - 1
                End If
                k = k + 1
                Rng(i, j).Copy Cells(51 + j, k)
                iStart = Rng(i, j).Row
            End If
        Next i
    Next j
End Sub

跳转到最佳答案楼层

amulee

Sub Test()
    Dim Rng As Range
    Dim i&, j%, k%
    Dim iStart&, iEnd&
    Set Rng = Range("A1:C" & Range("A" & Cells.Rows.Count).End(xlUp).Row)
    Range("F52:IV54").Clear
    For j = 1 To 3
        k = 5
        iStart = 0
        For i = Range("A" & Cells.Rows.Count).End(xlUp).Row To 1 Step -1
            If Rng(i, j).Interior.ColorIndex = 3 Then
                iEnd = Rng(i, j).Row
                If iStart > 0 Then
                    k = k + 1
                    Cells(51 + j, k) = iStart - iEnd - 1
                End If
                k = k + 1
                Rng(i, j).Copy Cells(51 + j, k)
                iStart = Rng(i, j).Row
            End If
        Next i
    Next j
End Sub