|
Sub 提取分层并去除描述再补全() 提取分层 岩性 补全 End Sub Sub 提取分层并去除描述() 提取分层 岩性 End Sub Sub 提取分层() '提取分层信息 '删除无用行，简化钻孔编号行 '----------------------------------- On Error Resume Next Dim Lastrow As Long, r As Long Lastrow = ActiveSheet.UsedRange.Rows.Count Lastrow = Lastrow + ActiveSheet.UsedRange.Row - 1 r = 1 Do While r <= Lastrow If InStr(Cells(r, 1), "钻孔编号") Then Cells(r, 1) = Mid(Cells(r, 1), 6, InStr(Cells(r, 1), " ") - 6) ElseIf Not IsNumeric(Left(Cells(r, 1), 1)) Then Rows(r).Delete Shift:=xlUp r = r - 1 Lastrow = Lastrow - 1 End If r = r + 1 Loop '提取钻孔编号，存储在该钻孔第一层左侧单元格中，并删除钻孔编号行 '----------------------------------- Lastrow = ActiveSheet.UsedRange.Rows.Count Columns("A:A").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove r = 1 Do While r <= Lastrow If Cells(r, 2) <> "" And Cells(r, 3) = "" Then Cells(r + 1, 1) = Cells(r, 2) Rows(r).Select Application.CutCopyMode = False Selection.Delete Shift:=xlUp r = r - 1 Lastrow = Lastrow - 1 End If r = r + 1 Loop End Sub Sub 岩性() Dim a() Dim i, m As Integer On Error Resume Next m = Cells(65536, 4).End(xlUp).Row ReDim a(1 To m) For i = 1 To m a(i) = Cells(i, 4) Next i For i = 1 To m If a(i) Like "*：全风化，*" Then Cells(i, 4) = "全风化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：强风化，*" Then Cells(i, 4) = "强风化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：中风化，*" Then Cells(i, 4) = "中风化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：微风化，*" Then Cells(i, 4) = "微风化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：未风化，*" Then Cells(i, 4) = "未风化" & Split(a(i), "：")(0) Else Cells(i, 4) = Split(a(i), "：")(0) End If Next End Sub Sub 补全() Dim i, m As Integer On Error Resume Next m = Cells(65536, 2).End(xlUp).Row For i = 2 To m If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1) End If Next i End Sub |
|
|
