数据表合并

friendcj

各位大神！打扰了！我是做石油测井解释的，我有个岩性数据表，想把相邻相同的岩性数据实现自动合并，谁能帮我一下！非常感谢！


上图左边是原始的岩性解释数据，深度段自上而下是连续的，也就是上一行的底深就是下一行的顶深，我想把相邻相同岩性的数据段进行合并，合并后为右边所示，如：某两行岩性相同，合并后顶深为第一行的“顶深”，底深为相邻相同岩性最后一行的“底深”

ykcbf1100

请上传附件。

friendcj

ykcbf1100 发表于 2024-9-13 10:24
请上传附件。

已经上传了，不知道您能看到不？

friendcj

已经上传了，谢谢提醒！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.13
   
2.     r = Cells(Rows.Count, 1).End(3).Row
   
3.     arr = [a2].Resize(r - 1, 5)
   
4.     [h2].Resize(UBound(arr), UBound(arr, 2)) = arr
   
5.     arr = [h1].Resize(r, 5)
   
6.     ReDim brr(1 To r, 1 To 5)
   
7.     ReDim zrr(1 To 10000)
   
8.     For i = 3 To UBound(arr)
   
9.         If arr(i, 5) <> arr(i - 1, 5) Then m = m + 1: zrr(m) = Array(i, i)
   
10.         If i = r Then zrr(m)(1) = r
    
11.         If i < r Then
    
12.             If arr(i, 5) = arr(i - 1, 5) And arr(i, 5) <> arr(i + 1, 5) Then zrr(m)(1) = i
    
13.         End If
    
14.     Next
    
15.     For x = 1 To m
    
16.         r1 = zrr(x)(0): r2 = zrr(x)(1)
    
17.         n = r2 - r1 + 1
    
18.         If n > 1 Then
    
19.             Cells(r1, "k") = Application.Sum(Cells(r1, "k").Resize(n))
    
20.             Cells(r1 + 1, "h").Resize(n - 1, 5) = ""
    
21.         End If
    
22.     Next
    
23. End Sub
    
24. 
    

复制代码

扇扇扇

，，，，，，

friendcj

ykcbf1100 发表于 2024-9-13 11:18
附件供参考。。。

非常感谢！祝中秋节快乐！身体健康！

friendcj

扇扇扇 发表于 2024-9-13 11:51
，，，，，，

感谢帮助！祝中秋节快乐！身体健康！

cnmlgb9998

PQ解决这种问题，轻轻松松！！！！！！！！！！！