加上VAL测试OK- Sub qq()
- Dim r%, i%, j%, arr, brr(1 To 1000, 1 To 2)
- Columns("f:g").Clear
- r = Cells(Rows.Count, 1).End(xlUp).Row
- arr = Range("a2:b" & r)
- j = 1
- For i = 1 To UBound(arr) - 1
- brr(j, 1) = arr(i, 1)
- If i = 1 Then
- brr(j, 2) = arr(i, 2): brr(j + 1, 2) = arr(i, 2)
- Else
- brr(j - 1, 2) = arr(i, 2): brr(j, 2) = arr(i, 2): brr(j + 1, 2) = arr(i, 2)
- End If
- Do
- j = j + 1
- brr(j, 1) = Val(brr(j - 1, 1) + 0.1)
- Loop While Val(brr(j, 1) + 0.1) < Val(arr(i + 1, 1))
- j = j + 1
- Next
- brr(j, 1) = arr(i, 1): brr(j, 2) = arr(i, 2): brr(j - 1, 2) = arr(i, 2)
- [f2:g2].Resize(j) = brr
- End Sub
复制代码 |