SEARCH

The How-To Geek Forums Have Migrated to Discourse

How-To Geek Forums / Microsoft Office

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

(51 posts)
  • Started 1 year ago by Eligeol
  • Latest reply from Eligeol
  • Topic Viewed 3983 times

Enthusiast
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

    '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
Posted 1 year ago
Top
 
moreeg
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 1 year ago
Top
 
Enthusiast
Enthusiast
Posts: 566

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

Interesting :)

Posted 1 year ago
Top
 
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 1 year ago
Top
 
Enthusiast
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 1 year ago
Top
 
Enthusiast
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

    '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

    '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 1 year ago
Top
 
moreeg
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 1 year ago
Top
 
Enthusiast
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 1 year ago
Top
 
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 1 year ago
Top
 
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 1 year ago
Top
 
Enthusiast
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 1 year ago
Top
 
Enthusiast
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

'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

'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 1 year ago
Top
 
moreeg
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 1 year ago
Top
 
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

'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

'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 1 year ago
Top
 
moreeg
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

'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

'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 1 year ago
Top
 
Eligeol
Posts: 31

Thanks moreeg! Much appreciated!!

Posted 1 year ago
Top
 
Enthusiast
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 1 year ago
Top
 
moreeg
moreeg
Posts: 842

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

Posted 1 year ago
Top
 
Enthusiast
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 1 year ago
Top
 
Enthusiast
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

'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

'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 1 year ago
Top
 



Topic Closed

This topic has been closed to new replies.

Get Free Articles in Your Inbox!

Join 134,000 newsletter readers

Email:

Go check your email!