提取分层() '
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