|
Sub 提取分層并去除描述再補(bǔ)全() 提取分層 巖性 補(bǔ)全 End Sub Sub 提取分層并去除描述() 提取分層 巖性 End Sub Sub 提取分層() '提取分層信息 '刪除無(wú)用行，簡(jiǎn)化鉆孔編號(hào)行 '----------------------------------- 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), "鉆孔編號(hào)") 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 '提取鉆孔編號(hào)，存儲(chǔ)在該鉆孔第一層左側(cè)單元格中，并刪除鉆孔編號(hào)行 '----------------------------------- 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 "*：全風(fēng)化，*" Then Cells(i, 4) = "全風(fēng)化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：強(qiáng)風(fēng)化，*" Then Cells(i, 4) = "強(qiáng)風(fēng)化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：中風(fēng)化，*" Then Cells(i, 4) = "中風(fēng)化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：微風(fēng)化，*" Then Cells(i, 4) = "微風(fēng)化" & Split(a(i), "：")(0) ElseIf a(i) Like "*：未風(fēng)化，*" Then Cells(i, 4) = "未風(fēng)化" & Split(a(i), "：")(0) Else Cells(i, 4) = Split(a(i), "：")(0) End If Next End Sub Sub 補(bǔ)全() 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 |
|
|
