求助大神用切西瓜的思路解决桩号分段问题

A星星啊

如图，A:C列为原始数据，数据从小到大排列并且首尾连续，现在需要左侧数据根据不同属性，划分100m段落并连续排列，生成E：G的数据。

当左侧段落不是整百起点或整百终点，需要将首尾划分为非100段，如480-540，需要划分为190-200,200-300,300-360这3个区间，即逢整百，就需要划分断开

sdytsxd991122

yjh_27

1. Sub aa()
   
2. r = Range("a" & Rows.Count).End(xlUp).Row
   
3. arr = Range("a2:c" & r)
   
4. r = arr(UBound(arr), 2) / 100 + UBound(arr)
   
5. ReDim brr(1 To r, 1 To 3)
   
6. 
   
7. ii = 0
   
8. For i = 1 To UBound(arr)
   
9.     Do While Int(arr(i, 1) / 100 + 1) * 100 < arr(i, 2)
   
10.         ii = ii + 1
    
11.         brr(ii, 1) = arr(i, 1)
    
12.         arr(i, 1) = Int(arr(i, 1) / 100 + 1) * 100
    
13.         brr(ii, 2) = arr(i, 1)
    
14.         brr(ii, 3) = arr(i, 3)
    
15.     Loop
    
16.     ii = ii + 1
    
17.     For j = 1 To 3
    
18.         brr(ii, j) = arr(i, j)
    
19.     Next
    
20. Next
    
21. 
    
22. Range("i2").Resize(ii, 3) = brr
    
23. End Sub
    

复制代码

Qs18

1. Sub qs()
   
2. Dim arr, i, j
   
3. m = 0
   
4. With Sheet1
   
5.     arr = .Range("a1").CurrentRegion.Value
   
6.     ReDim brr(1 To 60000, 1 To 3)
   
7.     For i = 2 To UBound(arr)
   
8.         If arr(i, 1) > 0 Then
   
9.             s = Application.WorksheetFunction.RoundUp(arr(i, 1), -2)
   
10.             m = m + 1
    
11.             brr(m, 1) = arr(i, 1): brr(m, 2) = s: brr(m, 3) = arr(i, 3)
    
12.         End If
    
13.         If m = 0 Then
    
14.         For j = Val(arr(i, 1)) To Val(arr(i, 2)) Step 100
    
15.             m = m + 1
    
16.                 brr(m, 1) = j
    
17.                 brr(m, 2) = j + 100
    
18.                
    
19.                 brr(m, 3) = arr(i, 3)
    
20.                 If brr(m, 2) > Val(arr(i, 2)) Then
    
21.                     brr(m, 2) = Val(arr(i, 2))
    
22.                     Exit For
    
23.                 End If
    
24.         Next
    
25.         Else
    
26.             For j = s To Val(arr(i, 2)) Step 100
    
27.             m = m + 1
    
28.                 brr(m, 1) = j
    
29.                 brr(m, 2) = j + 100
    
30.                
    
31.                 brr(m, 3) = arr(i, 3)
    
32.                 If brr(m, 2) > Val(arr(i, 2)) Then
    
33.                     brr(m, 2) = Val(arr(i, 2))
    
34.                     Exit For
    
35.                 End If
    
36.         Next
    
37.         End If
    
38.     Next
    
39. .Range("e2").Resize(m, 3) = brr
    
40. End With
    
41. End Sub

复制代码

Qs18

试试........

Qs18

试试...........

micch

1. Sub Main()
   
2.     ar = Range("A1").CurrentRegion.Value
   
3.     ReDim br(1 To 10000, 1 To 3)
   
4.     For i = 2 To UBound(ar)
   
5.         j = ar(i, 1)
   
6.         k = (ar(i, 1) \ 100) * 100 + 100
   
7.         While j < ar(i, 2)
   
8.             r = r + 1
   
9.             br(r, 1) = j
   
10.             br(r, 2) = k
    
11.             br(r, 3) = ar(i, 3)
    
12.             j = k
    
13.             k = k + 100
    
14.             If k > ar(i, 2) Then k = ar(i, 2)
    
15.         Wend
    
16.     Next
    
17.     Range("E2").Resize(r, 3).Value = br
    
18. End Sub
    

复制代码

cnmlgb9998

用PQ 解决！


你一题，发了几个区。服了你！版主要处理你。

A星星啊

micch 发表于 2024-9-22 18:25

您好，为什么在600的位置会重复计算呢

A星星啊

Qs18 发表于 2024-9-22 18:09
试试...........

您好，为什么在600的位置为重复统计桩号呢