Sub ggfg()
Dim arr, brr()
arr = [a1].CurrentRegion
ReDim brr(1 To 55555, 1 To UBound(arr, 2))
k = 1
For j = 1 To UBound(brr, 2)
brr(1, j) = arr(1, j)
Next
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
If arr(i, j) <> "" Then
y = Int(arr(i, j) / 150)
If y = 0 Then
k = k + 1
brr(k, 1) = arr(i, 1)
brr(k, j) = arr(i, j)
Else
For x = 1 To y
k = k + 1
brr(k, 1) = arr(i, 1)
brr(k, j) = 150
Next
If arr(i, j) - 150 * y > 0 Then
k = k + 1
brr(k, 1) = arr(i, 1)
brr(k, j) = arr(i, j) - 150 * y
End If
End If
End If
Next
Next
[g1].Resize(k, UBound(brr, 2)) = brr
End Sub |