I have created a routine that will loop through your data and generate a report, to the right of your data (Columns E,F & G) that lists your sedimentary layers, removing the Dolerite layers and shifting the other layers accordingly.
First, open the worksheet containing your information (so you can save the macro code in that worksheet)
1. Create a macro and give it a name (I used Analyze) and a ctrl-letter key combination (I used ctrl-a, for Analyze)
2. Select cell A1 by clicking in it (to give the macro a line of code)
3. Stop the macro recording.
4. Edit the macro (Tools->Macro->(Click macro name)->Edit
5. Delete the line that says: Range("A1").Select
6. Paste the following code into the same line:
'
' Analysis Macro
' Macro recorded by Enthusiast
'
' Keyboard Shortcut: Ctrl+a
'
'
' This macro generates a report of sediment layers and thicknesses 4 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 we are processing
Dim CalcMode As Long ' Save calculation state here
Dim ViewMode As Long ' Save view state here
Dim strDescription As String ' Current description
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 strRptLayerTypeColumn As String ' Column Layer Type is in
Dim strRptLayerBeginColumn As String ' Column Layer Begin is in
Dim strRptLayerEndColumn As String ' Column Layer End is in
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 LayerBegin
strLayerBeginColumn = "A"
strRptLayerBeginColumn = "E"
'Set column for LayerEnd
strLayerEndColumn = "B"
strRptLayerEndColumn = "F"
'Set column for LayerType
strLayerTypeColumn = "C"
strRptLayerTypeColumn = "G"
'Save state and turn off auto-calculate and screen updating, for speed
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through,
'Firstrow + 1 to allow for header row, remove "+1" if no header row
Firstrow = .UsedRange.Cells(1).Row + 1
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'Set Output start row for the report, 2 lines below data reporting on
' Change 2 to whatever distance below data you want the report
'rptRow = Lastrow + 2
rptRow = 1
'Initialize Delta
dblDelta = 0
'Print report header
.Cells(rptRow, strRptLayerBeginColumn).Value = "Layer Begin"
.Cells(rptRow, strRptLayerEndColumn).Value = "Layer End"
.Cells(rptRow, strRptLayerTypeColumn).Value = "Layer Type"
'Increment report row
rptRow = rptRow + 1
'We loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1
'Set Descriptions to initial values
strDescription = .Cells(Lrow, strLayerTypeColumn).Value
'Begin Layer values are in column strLayerBeginColumn
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
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, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
'increment report line
rptRow = rptRow + 1
End If
Next Lrow
'Print final report line
'.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
'.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
'.Cells(rptRow, strRptLayerTypeColumn).Value = "Layer Type"
End With
'Return screen updates and auto-calculation to initial settings
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
7. leave the Procedure name and the "End Sub" statements intact at the beginning and end.
8. Save the code (Clicking the upper-right X will save and close the Visual Basic editor).
9. Save your worksheet (IMPORTANT!) This way if something goes wrong you have not lost your data.
9. Back in your worksheet, hold ctrl-(whatever letter you chose for your macro) to generate the analysis.
10. If you need/want to rerun the macro, delete the columns to the right of your data and re-generate the analysis.
If you have any questions, please post back.
