## (Solved) - Removing rows and recalculating depth intervals in Excel 2010

(51 posts)
• Started 5 years ago by Eligeol
• Topic Viewed 3983 times

Eligeol
Posts: 31

Hi All,
I have a challenge which I hope someone can help me with. I have a bunch of data from holes drilled into the earth and I need to remove certain layers and recalculate or “bump up” the layers below. E.g.:
0 2.7 No Core
2.7 4.07 Dolerite Fine
4.07 6.96 Sandstone Fine
6.96 7.9 Sandstone Medium
7.9 13.38 Dolerite Fine
13.38 15.68 Sandstone Fine
15.68 15.76 Conglomerate
15.76 18.9 Sandstone Medium
18.9 24.42 Sandstone Fine
24.42 25.57 Sandstone Medium
25.57 27.4 Siltstone
27.4 28.43 Dolerite Fine
28.43 30 Siltstone
30 46.26 Shale (Light)
46.26 50 Dolerite Fine
50 57.78 Dolerite Medium
57.78 60.88 Dolerite Fine
60.88 65.28 Shale (Dark)

I need to remove all the layers called "Dolerite" (Fine, Medium & Coarse etc) and move each of the other layers up by whatever the thickness of the Dolerite layer is to get this:
0 2.7 No Core
2.7 5.59 Sandstone Fine
5.59 6.53 Sandstone Medium
6.53 8.83 Sandstone Fine
8.83 8.91 Conglomerate
8.91 12.05 Sandstone Medium
12.05 17.57 Sandstone Fine
17.57 18.72 Sandstone Medium
18.72 20.55 Siltstone
20.55 22.12 Siltstone
22.12 38.38 Shale (Light)
38.38 42.78 Shale (Dark)

Is there some sort of formula that I can use or way of doing this besides the very tedious manual way I have been using so far? There are about 300 of these to do!

Posted 5 years ago

moreeg
Posts: 842

Hi
You'll need to explain the relationship between dolerite and what you take off the remaining entries. This is what I get...

how do you calculate 1.37, 6.65, 7.88 and 22.5 removed.

Also, is this a one time exercise or are you going to need to do similar things with different entries.

Posted 5 years ago

Eligeol
Posts: 31

Hi moreeg,

Ok - basically what I am trying to do is to remove the Dolerite (which is an igneous intrusion that has "disrupted" the sedimentary layers and therefore changed the original depths that each of these layers originally occurred at). Rock layers are continuous (ie. there are no gaps between these layer beneath our feet) so if I remove the Dolerite layers then I need to shift all the other layers up by the thickness of the Dolerite I have removed.
Also - because Dolerite only occurs in some of my study area and not in others it is a bit of a nuisance and I cant compare layers across the area of interest. Could you possibly elaborate on what formula you used to get Columns D to H?

To answer your second question - yes I would possibly like to remove other layers (which ones will depend on what I get from this initial excercise).

Thanks again - I knew there would be an expert out there who would know how this could be done :) I appreciate your help.

Posted 5 years ago

Enthusiast
Posts: 566

moreeg,

Those numbers are the thicknesses of the Dolerite layers. He is removing those thicknesses from the sample.

Posted 5 years ago

Enthusiast
Posts: 566

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

.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.

Posted 5 years ago

moreeg
Posts: 842

Funny this should be about thickness. I kept reading the words and nothing was penetrating the thick skull. I finally got it when I went through your macro.

Posted 5 years ago

Enthusiast
Posts: 566

LOL. I hope the OP returns :)

Posted 5 years ago

moreeg
Posts: 842

I'm sure he will. It would be a shame if he didn't after the work you've put into this. How long did it take you to write the macro?

Posted 5 years ago

Enthusiast
Posts: 566

I spent about an hour with it. It is fun :)

Posted 5 years ago

moreeg
Posts: 842

I agree - it is fun but apparently much more fun for me because I figure that would have taken me 4-5 hours to complete (once I understood what the problem was which - it seems - would have taken some time too). I'm jealous.

Posted 5 years ago

Eligeol
Posts: 31

Wow! Thank you sooo much.
I havent used macro's in Excel before so this would be a very good introduction. Let me follow your steps and I'll post back later.

Thanks again - I really appreciate your time and effort on this!!!!

Posted 5 years ago

Eligeol
Posts: 31

Hi again Enthusiast,

I seem to be having a problem with a Run-time error '13' - Type Mismatch message. When I click on Debug - it highlights this line:

dblEnd = .Cells(Lrow, strLayerEndColumn).Value

I think it might be because one of my holes ends with dolerite? This is the section where the problem is:
97.49 100.58 Sandstone Medium 72.64 73.19 Coal
100.58 101.1 Sandstone Coal Lenses 73.19 73.74 Shale (Dark)
101.1 101.8 Shale Inclusions -31.84 -29.64 No Core
101.8 102.02 Sandstone Fine -29.64 -26.97 Siltstone
102.02 102.4 Conglomerate -26.97 -9.81 Siltstone
102.4 102.95 Coal -9.81 -7.94 Sandstone Fine
102.95 103.5 Shale (Dark) -138.32 -134.75 No Core
103.5 105.58 Dolerite -134.75 -133.87 Sandstone Fine
0 2.2 No Core -133.87 -127.47 Shale (Light)
2.2 30 Dolerite -127.47 -125.06 Shale (Light)
30 34.7 Dolerite -125.06 -113.11 Shale (Light)
34.7 41.83 Dolerite -113.11 -96.78 Sandstone Fine
41.83 44.5 Siltstone -96.78 -95.67 Sandstone Medium

Is there a way to modify the macro for this? What I have been doing manually (before your help with the macro) is to remove all dolerite including the ones where the hole ends in the dolerite.

Thanks again

Posted 5 years ago

Enthusiast
Posts: 566

Eligeol,
I based the code on the scenario presented. Your sample data started at zero and went up from there. Three columns, where the layer begins, where the layer ends and the description of the sediment type.

If this is not the case, the code will fail. The "Type Mismatch" error leads me to think one of your numerical values contains non-numerical characters or is in the wrong place. Post the sample data that the failure occurred on and I will take a look at it.

Posted 4 years ago

Enthusiast
Posts: 566

The data you just presented is not in the same format as the original posting. You are now showing 6 columns, and some of the numbers are negative. Please explain this new format and I will see what I can do.

Posted 4 years ago

Eligeol
Posts: 31

Hi again,

Ok - this is totally my fault - I apologise profusely.
I copied just a selection of the data (to keep things simple). The database is large but it appears as below (just for the first hole) (Columns A to E):
Would it be possible for me to email you my Excel sheet - if that would make it simpler? There are just over 19000 lines in Excel so I cant post it here?

Bore Depth1 Depth2 Lithology Comment
AN001 0 0.14 No Core
AN001 0.14 3.73 SANDSTONE FINE Massive, lenses
AN001 3.73 4 SANDSTONE MEDIUM
AN001 4 13.15 SANDSTONE FINE
AN001 13.15 14.98 SANDSTONE MEDIUM
AN001 14.98 15.98 SANDSTONE FINE
AN001 15.98 16.28 Coal Less than1% Bright
AN001 16.28 16.45 SANDSTONE MEDIUM
AN001 16.45 21.93 SANDSTONE FINE Massive
AN001 21.93 22.98 SANDSTONE MEDIUM
AN001 22.98 26.56 SANDSTONE FINE Shaly lenses
AN001 26.56 27.94 SHALE/SANDSTONE cs lenses
AN001 27.94 33.78 SANDSTONE FINE Massive,lenses
AN001 33.78 33.88 Coal Dull
AN001 33.88 33.94 SHALE (DARK)
AN001 33.94 36.25 Seam AN001A
AN001 36.25 36.85 SHALE (DARK)
AN001 36.85 37.3 Seam AN001B
AN001 37.3 37.51 SHALE (DARK)
AN001 37.51 37.58 Carbonaceous Shale
AN001 37.58 39.04 SHALE (DARK)
AN001 39.04 42.09 SANDSTONE FINE Laminated
AN001 42.09 42.29 SHALE (DARK)
AN001 42.29 46.87 SANDSTONE FINE Laminated,interlaminated
AN001 46.87 47.05 SHALE/SANDSTONE Shaly incl.cs lenses
AN001 47.05 52.93 SANDSTONE FINE Laminated,lenses
AN001 52.93 53 SHALE/SANDSTONE sd in shale
AN001 53 53.45 SANDSTONE FINE Interlaminated
AN001 53.45 54.66 SHALE (DARK)
AN001 54.39 54.66 SHALE (DARK) Silty
AN001 56.03 56.26 SHALE (DARK)
AN001 56.26 56.35 Carbonaceous Shale Coaly bands
AN001 56.35 61.09 SHALE (DARK) Silty
AN001 61.09 64.41 SANDSTONE FINE Laminated,lenses
AN001 64.41 66.32 SANDSTONE MEDIUM Laminated
AN001 66.32 66.84 SANDSTONE FINE Laminated,x-bedded
AN001 66.84 67.17 SANDSTONE MEDIUM
AN001 67.17 79.3 Shale Inclusions Laminated+massive,shaly incl.
AN001 79.3 81.95 SANDSTONE MEDIUM Laminated
AN001 81.95 82.07 SHALE (DARK)
AN001 82.07 83.17 SANDSTONE FINE Thickly laminated,lenses
AN001 83.17 84.09 SHALE (DARK)
AN001 84.09 84.49 Mudstone Greenish
AN001 84.49 85.11 SHALE (DARK)
AN001 85.11 85.99 SILTSTONE
AN001 85.99 86.13 Mudstone
AN001 86.13 86.68 SILTSTONE Laminated
AN001 86.68 89.32 SHALE (DARK)
AN001 89.32 90.13 Mudstone
AN001 90.13 92.09 SHALE/SILTSTONE Interlaminated,ripple x-laminated
AN001 92.09 94.62 SHALE (DARK) Silty
AN001 94.62 95.39 Mudstone
AN001 95.39 96.13 SHALE (DARK)
AN001 96.13 96.94 Mudstone Shaly
AN001 96.94 97.49 SHALE (DARK)
AN001 97.49 98.04 SILTSTONE Muddy
AN001 98.04 99.24 Mudstone Shaly
AN001 99.24 100.06 SILTSTONE Massive
AN001 100.06 100.6 SHALE (DARK)
AN001 100.6 101.67 Mudstone
AN001 101.67 103.02 SHALE (DARK)
AN001 103.02 105.28 SILTSTONE Sandy
AN001 105.28 107.51 SANDSTONE FINE Laminated
AN001 107.51 111.95 Dolerite Fine Intrusive with calcitic veins
AN001 111.95 115.96 SILTSTONE Ripple x-laminated
AN001 115.96 116.57 SHALE/SILTSTONE Interlaminated,speckles
AN001 116.57 116.87 SILTSTONE Laminated
AN001 116.87 117.67 Mudstone
AN001 117.67 118.61 SHALE (DARK)
AN001 118.61 120.03 Mudstone Shaly
AN001 120.03 120.86 SILTSTONE
AN001 120.86 123.12 SHALE (DARK)
AN001 123.12 123.85 SANDSTONE FINE Laminated,lenses
AN001 123.85 124.28 SHALE/SILTSTONE Interlaminated,lenses,speckles
AN001 124.28 132.17 Shale Inclusions Laminated,lenses,shaly incl.
AN001 132.17 132.44 SHALE (DARK)
AN001 132.44 132.71 SHALE/SILTSTONE Thinly laminated,ripple x-laminated
AN001 132.71 136.89 Shale Inclusions Shaly incl.
AN001 136.89 137.45 SHALE (DARK)
AN001 137.45 137.5 SANDSTONE FINE
AN001 137.5 137.97 SHALE/SANDSTONE Ripple x-laminated
AN001 137.97 138.99 SHALE (DARK) Ripple x-laminated
AN001 138.99 139.62 SANDSTONE FINE Interlaminated,banded
AN001 139.62 141.8 SHALE (DARK) Silty
AN001 141.8 143.25 SILTSTONE Shaly
AN001 143.25 146.29 Mudstone Reddish in parts
AN001 146.29 146.44 SHALE (DARK) Muddy
AN001 146.44 150.16 SANDSTONE FINE Massive
AN001 150.16 151.44 Mudstone Reddish in parts

It might be posisble that some of the cells are not registered by Excel as a number - should I select all the Depth1 & Depth2 cells and make them number cells instead of General cells?

I have used Excel for many years but on a fairly low level but as time goes on I'm amazed at what it can do especially coming from a generation where we had to teach ourselves. If I can ask one more question of you - where did you learn to write macros?

Thanks!

Posted 4 years ago

Enthusiast
Posts: 566

I am looking into this latest information. Is this the standard format for your data? If so, I will modify the macro to work with the data as presented.

As for myself and macros, I am an old school programmer (self-taught). The code I generated is a VBA procedure with a macro front-end (it makes it easier for the end-user to access). If your search "excel macro tutorial" you should get more than your share of information regarding how to code macros.

Feel free to email me the worksheet, my email address is in my profile. Click the word "Member" under my name to the left of my posts.

Posted 4 years ago

Enthusiast
Posts: 566

Thank you.

Posted 4 years ago

vistamike
Posts: 10945

tis done

Posted 4 years ago

Enthusiast
Posts: 566

I have updated the macro to handle the latest information. Waiting to hear if this is the standard format before posting it.

Posted 4 years ago

moreeg
Posts: 842

Hi Vincent

It was fascinating going through your code. You went through a similar thought process that I went through - starting with calculating the delta of the layer thickness with the intention of recalculating when you hit an instance of Dolerite but then realizing that all that was needed was to use the next instance of beginning and ending layers, From there it was "only" a matter of varying the the reporting row and the input row which you did elegantly by skipping the reporting layer bump in your "if" statement.

But, that's where the similarity ends. As I said - it would have taken me 4 or 5 times longer to code this and the end result would not have been as comprehensive and elegant as yours. If you don't mind, could you post the revised code so I can see how you dealt with the additional columns?
thanks
Moree

Posted 4 years ago

Enthusiast
Posts: 566

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

.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
Posted 4 years ago

moreeg
Posts: 842

Thanks for that.

I was thinking the same - it would be easy enough putting in the msgbox where the user inputs the layer they want to delete although it could be even user friendlier if they are presented with a list of the layers from which they can select one or even several layers to delete. This would take some work since they seem to select based on the rock type without the additional qualifiers so this may not be a workable feature.

It will be interesting to see how this develops.

Posted 4 years ago

Enthusiast
Posts: 566

Hmmm, I will have to figure out how to get the layers list into an array for selection.

Interesting :)

Posted 4 years ago

Eligeol
Posts: 31

Hi Enthusiast,
Excellent ideas from you and Moreeg!

I've sent the file to your email - please work you magic :)
Thanks!

Posted 4 years ago

Enthusiast
Posts: 566

Eligeol,

I have taken a look at your file. I see almost 20,000 lines of layer information by bore. Can you explain how you process this information now, and whether you leave the output information in the same format (one after the other in the same columns). If so, how do you do your comparisons? Would you want the final procedure to leave the data in this format or separate it somehow?

Posted 4 years ago

Enthusiast
Posts: 566

Ok, the error "Type Mismatch" you got when you ran the procedure against your data is due to a typo on the 4th line of Core BH522. The layer end value was entered on that line as "8.54." with 2 decimal points. There is another problem with that line in that the layer end value is not the layer start value for the next layer.

Once that line is corrected the code below will process the entire file without error. Each new bore name will reset the process.

@moreeg: I posted this also to keep you up to speed. To see this code in action, take the latest data Eligeol supplied and copy it down a couple times, changing the Bore name for each copy. And maybe add a few more random Dolerite layers, his sample contains only 1. His headings are "Bore","Depth1","Depth2","Lithology","Comment".

Sub Analyze()
'
' Analyze Macro
'
' Keyboard Shortcut: Ctrl+a
'
' Macro recorded by Enthusiast
'
' 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = .Cells(Lrow, strLayerBeginColumn).Value
.Cells(rptRow, strRptLayerEndColumn).Value = .Cells(Lrow, strLayerEndColumn).Value
.Cells(rptRow, strRptLayerTypeColumn).Value = .Cells(Lrow, strLayerTypeColumn).Value
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, strCommentColumn).Value

'increment report line
rptRow = rptRow + 1

Else

'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

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, strCommentColumn).Value

'increment report line
rptRow = rptRow + 1

End If

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
Posted 4 years ago

moreeg
Posts: 842

Thanks Vincent

One thing I experimented with which I thought was useful (at least for me) was highlighting the deleted layers in the original list. I've. I stuck it in this section.....

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
If InStr(strDescription, "Dolerite") > 0 Then

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

Else
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
right before the "else" statement and set the range as

Range(Cells(Lrow,1),Cells(Lrow,5)).select

(Lrow is already set as the current input row being analysed which in this case is always a Dolerite instance as per the IF condition)

and then

Selection.Interior.Color = 65535

which will shade the target row yellow.

The problem with adding things like this is you have to start thinking about when you want to get rid of it (the shading in this case) and when you want to keep it (if you are doing additive deletes). And if you want to be really fancy, having a different colour if you delete several layers.

Posted 4 years ago

Enthusiast
Posts: 566

That's a great way to verify you are removing the right data from the output.

As time permits I am researching how to add a form with a listbox of sorted, unique layers (removing the "No Core" from the list) so that the user can select the layer to be removed, then passing that to the procedure.

Posted 4 years ago

Eligeol
Posts: 31

Hi again,

In answer to your question - yes it needs to be in the same format as it currently is in. The programme I use to model these layers requires it in this format i.e. continuous rows with no spaces. My frustration is that the programme doesnt allow you to remove layers from the holes like I need to do with the macro hence having to do it "manually".

P.S. I like the idea of the highlighting as a means of double checking that the correct layer is being removed but also understand that it might be an issue to get rid of that once you have confirmed the correct layers have been removed.

Thanks again.

Posted 4 years ago

Eligeol
Posts: 31

I see also what you mean about the BH522 lines - that is a typo: first one you pointed out then also the last line for BH522 should be removed. Thanks for that too!

Posted 4 years ago

Enthusiast
Posts: 566

@Eligeol, that last line of BH522 should not be removed, it is the missing layer from above. I moved it up to the correct place in the data stream.

@moreeg, your idea to highlight the lines being removed helped me find a flaw in the procedure. If the core sample begins with a Dolerite layer, the procedure doesn't remove it. Working on fixing that now. Thanks :)

Posted 4 years ago

Enthusiast
Posts: 566

I just had to do the Bore change reset then allow the normal process to continue. Updated procedure:

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 supplied data and standardizes the numeric values with
' 2 decimal places. To rerun report, delete the report columns then
' re-execute the 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

End If

'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

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

'Highlight row being removed Medium Light Green
Range(Cells(Lrow, 1), Cells(Lrow, 5)).Select
Selection.Interior.Color = 16776960

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, 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

Posted 4 years ago

moreeg
Posts: 842

A couple of things that may be useful ...

Another highlighting one. If you have 20,000 rows of data it might be useful to highlight where a new bore begins.

If .Cells(Lrow, strLayerBeginColumn).Value = 0 Then
Range(Cells(Lrow, strBoreColumn), Cells(Lrow, strCommentColumn)).Interior.Color = 776960
Range(Cells(rptRow, strRptBoreColumn), Cells(rptRow, strRptCommentColumn)).Interior.Color = 776960
End If

You can place this after the initial check for a new bore.

Also, in the data I am using - the set of 90 in the previous page of posts - there seems to be an error in the input data where there are 3 layers in a row that are the same and the end point of one is not equal to the beginning of the next. This would seemingly cause a problem with the recalculation of the depths using the delta. the group I'm referring to is

AN001 53.45 54.66 SHALE (DARK)
AN001 54.39 54.66 SHALE (DARK) Silty
AN001 56.03 56.26 SHALE (DARK)

and the result from the macro is

AN001 53.15 54.36 SHALE (DARK)
AN001 54.09 54.36 SHALE (DARK) Silty
AN001 55.73 55.96 SHALE (DARK)

In both cases the end of the first does not equal the beginning of the second.

This may just be a problem with the sample I have but if it is a possible error you can put in a check like this

If .Cells(Lrow, strLayerBeginColumn) <> 0 And .Cells(Lrow - 1, strLayerEndColumn) <> .Cells(Lrow, strLayerBeginColumn) Then
MsgBox ("ROW" & Lrow)
End If

Place this code after the code that set the end layer to be numeric ("'This code ensures dblBegin contains numeric data")

This will pop up a message box telling you which row has a problem and pressing enter will let the macro continue. It's an inelegant and annoying way to do this but if this is a potentially common problem we could come up with a better way to report this (e.g. another highlight).

Posted 4 years ago

Eligeol
Posts: 31

Hi moreeg,

You are correct - AN001 should be (essecially all the same layer but with a small silty "patch" in the middle):
AN001 53.45 54.39 SHALE (DARK)
AN001 54.39 54.66 SHALE (DARK) Silty
AN001 54.66 56.26 SHALE (DARK)

Posting on this forum has helped me in more ways than I could have imagined - thank you!

Considering I am very new to macros - Where exactly does the first code go? Have I placed the second code in the correct place below?:

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 supplied data and standardizes the numeric values with
' 2 decimal places. To rerun report, delete the report columns then
' re-execute the 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

End If

'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 .Cells(Lrow, strLayerBeginColumn) <> 0 And .Cells(Lrow - 1, strLayerEndColumn) <> .Cells(Lrow, strLayerBeginColumn) Then
MsgBox ("ROW" & Lrow)
End If

If InStr(strDescription, "Dolerite") > 0 Then

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

'Highlight row being removed Medium Light Green
Range(Cells(Lrow, 1), Cells(Lrow, 5)).Select
Selection.Interior.Color = 16776960

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, 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

Posted 4 years ago

moreeg
Posts: 842

Hi Eligeol

Here's the full macro with my additions highlighted so that they can be easily found and extracted if they don't work with your input and so that Vincent (Enthusiast) can clean it up if it needs it.

As I said, it will identify input errors with a pop up message. Make a note of the rows it identifies, fix the input and rerun the macro. If you get lots of errors we can change how you get alerted.

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 supplied data and standardizes the numeric values with
' 2 decimal places. To rerun report, delete the report columns then
' re-execute the 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

End If

'***************************************************************
'Highlight start of new bore
If .Cells(Lrow, strLayerBeginColumn).Value = 0 Then
Range(Cells(Lrow, strBoreColumn), Cells(Lrow, strCommentColumn)).Interior.Color = 776960
Range(Cells(rptRow, strRptBoreColumn), Cells(rptRow, strRptCommentColumn)).Interior.Color = 776960
End If
'**************************************************************

'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

'************************************************************************************************
'Finds errors in the input where depth2 does not equal next layer depth1
If .Cells(Lrow, strLayerBeginColumn) <> 0 And .Cells(Lrow - 1, strLayerEndColumn) <> .Cells(Lrow, strLayerBeginColumn) Then
MsgBox ("ROW" & Lrow)
End If
'*************************************************************************************************

If InStr(strDescription, "Dolerite") > 0 Then

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

'Highlight row being removed Medium Light Green
Range(Cells(Lrow, 1), Cells(Lrow, 5)).Select
Selection.Interior.Color = 16776960

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, 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

Posted 4 years ago

Eligeol
Posts: 31

Thanks moreeg! Much appreciated!!

Posted 4 years ago

Enthusiast
Posts: 566

Thanks moreeg,

I am under the weather lately, so haven't had much chance to advance this. I will hopefully be 100% soon.

Posted 4 years ago

moreeg
Posts: 842

Hope you feel better soon. And hope you don't mind me intruding on your code.

Posted 4 years ago

Enthusiast
Posts: 566

Your input is no imposition. As our goal is to aid the OP any input you have is welcome :) Keep it coming :)

Posted 4 years ago

Enthusiast
Posts: 566

Ok, I took a run at moreeg's suggestion, a good one. I did change it slightly, since stopping at each of what turned out to be several dozen transcription errors became tedious. This code update will end the macro when an error is found, displaying the row number, then displaying the error line, allowing corrections to be made. Once corrections have been made, simply rerun the macro to continue. I have also verified that bores starting in Dolerite have been handled appropriately.

Sub Analyze()
'
' Analyze Macro
'
' Keyboard Shortcut: Ctrl+a
'
' Macro recorded by Enthusiast
'

' This macro generates a report of sediment layers and thicknesses 6 columns
' to the right of the supplied data and standardizes the numeric values with
' 2 decimal places. To rerun report, delete the report columns then
' re-execute the 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

End If

'***************************************************************
'Highlight start of new bore
If .Cells(Lrow, strLayerBeginColumn).Value = 0 Then
Range(Cells(Lrow, strBoreColumn), Cells(Lrow, strCommentColumn)).Interior.Color = 776960
Range(Cells(rptRow, strRptBoreColumn), Cells(rptRow, strRptCommentColumn)).Interior.Color = 776960
End If
'**************************************************************

'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

'************************************************************************************************
'Finds errors in the input where depth2 does not equal next layer depth1
If .Cells(Lrow, strLayerBeginColumn) <> 0 And .Cells(Lrow - 1, strLayerEndColumn) <> .Cells(Lrow, strLayerBeginColumn) Then
MsgBox ("ROW: " & Lrow)

'Return screen updates and auto-calculation to initial settings
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

'Move pointer to the line with the error
.Cells(Lrow, strLayerBeginColumn).Select

'End the macro so user can make corrections
Exit Sub

End If
'*************************************************************************************************

If InStr(strDescription, "Dolerite") > 0 Then

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

'Highlight row being removed Medium Light Green
Range(Cells(Lrow, 1), Cells(Lrow, 5)).Select
Selection.Interior.Color = 16776960

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, 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
Posted 4 years ago

moreeg
Posts: 842

Hi Vincent

Glad to see you back and, hopefully, fully recovered.

I was surprised at the number of errors that came up. Perhaps we should be looking at whatever program is used to generate the raw data. :)
Also, just out of curiousity, how many bores were there?

Well ... It was fun while it lasted but I can't think of anything else that will add any more value to this. Thanks Vincent - I learned a lot from this about how the professionals construct code.

Posted 4 years ago

Enthusiast
Posts: 566

I'm getting there. It appears that the raw bores are processed by hand, with technicians manually entering the layer data. This process allows transcription errors to get into the data that we have been processing. I gather from Eligeol that the processing we have been doing is to prepare (clean) the data for an analysis. There are 522 bores in the data that was sent. The macro processes them in under 10 seconds.

Yes, there doesn't appear to be much more that needs to be done with this project. I would suggest to Eligeol that if other layers need to be removed, he can copy the Analyze macro to another macro, substituting the word "Dolerite" in the macro with the layer that he requires to be removed, and run that macro against the results of the first. Successive removals can be performed in this fashion.

Moreeg, as always, it has been fun working with you on this. Looking forward to the next time :)

I decided to make a final posting of the macro. This one reports the number of bores processed:

Sub Analyze()
'
' Analyze Macro
'
' Keyboard Shortcut: Ctrl+a
'
' Macro recorded by Enthusiast
'
' This macro generates a report of sediment layers and thicknesses 6 columns
' to the right of the supplied data and standardizes the numeric values with
' 2 decimal places. To rerun report, delete the report columns then
' re-execute the 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, used to detect Layer to be removed
Dim strBoreDescription As String ' Current Bore description, used to determine when we are processing a new Bore

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
Dim NumBores As Integer 'Number of Bores in the data

'Initialize NumBores
NumBores = 0

'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

.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

'Set BoreDescription to initial value
strBoreDescription = .Cells(rptRow, strBoreColumn).Value

'Loop from Firstrow to Lastrow (top to bottom)
For Lrow = Firstrow To Lastrow Step 1

'If this is the first row of a new Bore, reset dblDelta, print the line and repeat process
If strBoreDescription <> .Cells(Lrow, strBoreColumn).Value Then

'Increment NumBores
NumBores = NumBores + 1

'Reset Bore Description
strBoreDescription = .Cells(Lrow, strBoreColumn).Value

'Reset Delta
dblDelta = 0

End If

'***************************************************************
'Highlight start of new bore
If .Cells(Lrow, strLayerBeginColumn).Value = 0 Then
Range(Cells(Lrow, strBoreColumn), Cells(Lrow, strCommentColumn)).Interior.Color = 776960
Range(Cells(rptRow, strRptBoreColumn), Cells(rptRow, strRptCommentColumn)).Interior.Color = 776960
End If
'**************************************************************

'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

'************************************************************************************************
'Finds errors in the input where depth2 does not equal next layer depth1
If .Cells(Lrow, strLayerBeginColumn) <> 0 And .Cells(Lrow - 1, strLayerEndColumn) <> .Cells(Lrow, strLayerBeginColumn) Then
MsgBox ("ROW: " & Lrow)
'Return screen updates and auto-calculation to initial settings
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

'Move pointer to the line with the error
.Cells(Lrow, strLayerBeginColumn).Select

'End the macro
Exit Sub
End If
'*************************************************************************************************

If InStr(strDescription, "Dolerite") > 0 Then

' Add thickness of removed layer to Delta
dblDelta = dblDelta + (dblEnd - dblBegin)

'Highlight row being removed Medium Light Green
Range(Cells(Lrow, 1), Cells(Lrow, 5)).Select
Selection.Interior.Color = 16776960

Else

'Print report line
.Cells(rptRow, strRptBoreColumn).Value = .Cells(Lrow, strBoreColumn).Value
.Cells(rptRow, strRptLayerBeginColumn).Value = dblBegin - dblDelta
.Cells(rptRow, strRptLayerEndColumn).Value = dblEnd - dblDelta
.Cells(rptRow, strRptLayerTypeColumn).Value = strDescription
.Cells(rptRow, strRptCommentColumn).Value = .Cells(Lrow, 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

'Display Number of Bores
MsgBox ("Number of Bores: " & NumBores)

End Sub
Posted 4 years ago

moreeg
Posts: 842

Hey Vincent

Good addition although it seems to skip the initial bore in the count (easy for me to see because I only have 2 bores in my sample). You can set the initial count to 1 ...

Moree

Posted 4 years ago

Enthusiast
Posts: 566

Yeah, that will do it. I didn't want to count 522, err 523 bores to verify the count :)

Posted 4 years ago

moreeg
Posts: 842

523 holes in the ground!!!????? Wait till the environmentalists hear about this. What ARE they looking for?

Posted 4 years ago

Enthusiast
Posts: 566

LOL, Eligeol would have to answer that. From what I have seen of the bores, I am thinking coal deposits, but that is just a guess.

Posted 4 years ago

Lighthouse
Posts: 13598

Those pesky gophers again.

Posted 4 years ago

Eligeol
Posts: 31

Hi all,

Sorry for the late reply - been away from office (and internet) for the last few days. Thanks for the macro and all the efforts put in by Vincent and moreeg - I really appreciate it - especially since it completes the task in a fraction of the time it would have taken me to do it! Yes, you are quite right - tech's were used to input the data and unfortulately this was a) from handwritten logs and b) done by people who weren't able to double check for errors.

To answer the broader question - we are looking for coal in a rather large area so all of these holes are distributed over an extensive area. And not to worry according to our Evironmental Management Plan we rehabilitate all holes to the point that you wouldnt be able to see where we drilled two weeks after drilling :)

Thanks again - I look forward to challenging you again in the not-too-distant future :)

Keep well!

Accepted Answer · Posted 4 years ago

Enthusiast
Posts: 566

You are quite welcome :) Imagine... rehabilitated holes, hehehe

Posted 4 years ago

Lighthouse
Posts: 13598

No gophers were harmed in the re-filling of the holes :)

Posted 4 years ago

Eligeol
Posts: 31

hehe - no :)

Posted 4 years ago

## Topic Closed

This topic has been closed to new replies.