moreeg, I am thinking about adding a input box, so that the user can specify the text of the layer to remove, since the OP hinted that once he can remove the Dolerite, he may be interested in removing other layers.
Here you go:
Sub Analyze()
'
' Analyze Macro
'
' Macro recorded by Enthusiast
'
' Keyboard Shortcut: Ctrl+a
'
'
' This macro generates a report of sediment layers and thicknesses 6 columns
' to the right of the information. To rerun report, delete the report columns
' then re-execute macro
'
Dim Firstrow As Long 'First row of data
Dim Lastrow As Long ' Last row of data
Dim Lrow As Long ' Current row being processed
Dim CalcMode As Long ' Save calculation state here
Dim ViewMode As Long ' Save view state here
Dim strDescription As String ' Current description
Dim strBoreColumn As String ' Column Bore is in
Dim strLayerTypeColumn As String ' Column Layer Type is in
Dim strLayerBeginColumn As String ' Column Layer Begin is in
Dim strLayerEndColumn As String ' Column Layer End is in
Dim strCommentColumn As String ' Column Comment is in
Dim strRptBoreColumn As String ' Column Bore is in for report
Dim strRptLayerTypeColumn As String ' Column Layer Type is in for report
Dim strRptLayerBeginColumn As String ' Column Layer Begin is in for report
Dim strRptLayerEndColumn As String ' Column Layer End is in for report
Dim strRptCommentColumn As String ' Column Comment is in for report
Dim dblDelta As Double ' Accumulated Difference (Totals of Dolerite layer thicknesses)
Dim dblBegin As Double ' Temporary Beginning of Current Layer
Dim dblEnd As Double ' Temporary End of Current Layer
Dim rptRow As Integer 'Report row for output
'Set column for Bore
strBoreColumn = "A"
strRptBoreColumn = "G"
'Set column for LayerBegin
strLayerBeginColumn = "B"
strRptLayerBeginColumn = "H"
'Set column for LayerEnd
strLayerEndColumn = "C"
strRptLayerEndColumn = "I"
'Set column for LayerType
strLayerTypeColumn = "D"
strRptLayerTypeColumn = "J"
'Set column for Comment
strCommentColumn = "E"
strRptCommentColumn = "K"
'Save state and turn off auto-calculate and screen updating, for speed
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Using the ActiveSheet
With ActiveSheet
'Select the sheet so we can change the window view
.Select
'Change LayerBegin and LayerEnd columns on report to number format
'with 2 decimal places, for consistency
.Columns(strRptLayerBeginColumn).NumberFormat = "0.00"
.Columns(strRptLayerEndColumn).NumberFormat = "0.00"
'If you are in Page Break Preview Or Page Layout view go
'back to Normal View, for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through,
'Firstrow + 1 to allow for header row, remove "+1" if there is no header row
Firstrow = .UsedRange.Cells(1).Row + 1
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'Set Output start row for the report
rptRow = 1
'Initialize Delta
dblDelta = 0
'Print report header
.Cells(rptRow, strRptBoreColumn).Value = .Cells(rptRow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = .Cells(rptRow, strLayerBeginColumn).Value
.Cells(rptRow, strRptLayerEndColumn).Value = .Cells(rptRow, strLayerEndColumn).Value
.Cells(rptRow, strRptLayerTypeColumn).Value = .Cells(rptRow, strLayerTypeColumn).Value
.Cells(rptRow, strRptCommentColumn).Value = .Cells(rptRow, strCommentColumn).Value
'Increment report row
rptRow = rptRow + 1
'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1
'Set Description to initial value
strDescription = .Cells(Lrow, strLayerTypeColumn).Value
'Begin Layer values are in column strLayerBeginColumn
'This code ensures dblBegin contains numeric data
If Not IsError(.Cells(Lrow, strLayerBeginColumn).Value) Then
dblBegin = .Cells(Lrow, strLayerBeginColumn).Value
Else
dblBegin = Val(.Cells(Lrow, strLayerBeginColumn).Value)
End If
'End Layer values are in column strLayerEndColumn
'This code ensures dblBegin contains numeric data
If Not IsError(.Cells(Lrow, strLayerEndColumn).Value) Then
dblEnd = .Cells(Lrow, strLayerEndColumn).Value
Else
dblEnd = Val(.Cells(Lrow, strLayerEndColumn).Value)
End If
If InStr(strDescription, "Dolerite") > 0 Then
' Update Delta
dblDelta = dblDelta + (dblEnd - dblBegin)
Else
'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(rptRow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(rptRow, strCommentColumn).Value
'increment report line
rptRow = rptRow + 1
End If
Next Lrow
End With
'Return screen updates and auto-calculation to initial settings
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
