Forum Discussion

Alexgreggio's avatar
Alexgreggio
Copper Contributor
Feb 26, 2023
Solved

Populating a table based on a specific set of intervals and structure

Hello,

 

I need some help with populating a table in a specific way. My input will be an array composed of Hole ID (Name of drill hole), the depth of each drill hole and then the depth of the sensors installed along that drill hole in meters, like in the example here below.

 

 

I will then have a cell called "Length of sensor" which is a number that expresses the vertical length of the sensor in meters. I can change that number as I wish. See example here below

 

I want now to write a table that has a specific structure because it needs to feed into another software. I must cover the total depth of the hole starting from 0 meters but subdividing the intervals according to the presence of the sensors or the lack thereof. 

The depth of the sensor in table 1 is the center of the sensor and the length is equally divided in two intervals above and below the sensor. So the first interval will go from 0 to 2m above the first sensor (because in this case the length of the sensor is 4m). Then the second interval will be the first sensor which goes from 2m above the first sensor to 2m below it. Then the third interval will go from 2m below the first sensor to 2m above the second sensor and so on. Please note I want to also write the name of the drill hole that pertains to the relevant drill hole along all the intervals. I also want to write "Sensor x" next to the interval where the sensor is. Please note that sometimes the last sensor is at the bottom of the hole (like in the first drill hole), sometimes the drill hole continues down to the end of it without sensors.  

Here below is an example of the table I want to write based on these three drill holes and the depths and length of the sensors provided:

 

 

Can anybody help with how to get to this table? It would be greatly appreciated!

Thank you

  • Alexgreggio 

    A macro solution:

    Sub CreateList()
        Dim ws As Worksheet
        Dim wt As Worksheet
        Dim r As Long
        Dim m As Long
        Dim c As Long
        Dim n As Long
        Dim l As Double
        Dim t As Long
        Dim h As String
        Dim d As Double
        Dim s As Double
        Dim x As Double
        Application.ScreenUpdating = False
        Set ws = ActiveSheet
        m = ws.Cells(1, 1).End(xlDown).Row
        n = ws.Cells(1, 1).End(xlToRight).Column
        l = ws.Cells(2, 8).Value / 2
        Set wt = Worksheets.Add(After:=ws)
        For r = 2 To m
            h = ws.Cells(r, 1).Value
            d = ws.Cells(r, 2).Value
            x = 0
            c = 3
            Do While ws.Cells(r, c).Value <> ""
                s = ws.Cells(r, c).Value
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = x
                wt.Cells(t, 3).Value = s - l
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = s - l
                wt.Cells(t, 3).Value = s + l
                wt.Cells(t, 4).Value = ws.Cells(1, c).Value
                x = s + l
                c = c + 1
            Loop
            If d > x Then
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = x
                wt.Cells(t, 3).Value = d
            End If
        Next r
        Application.ScreenUpdating = True
    End Sub

2 Replies

  • Alexgreggio 

    A macro solution:

    Sub CreateList()
        Dim ws As Worksheet
        Dim wt As Worksheet
        Dim r As Long
        Dim m As Long
        Dim c As Long
        Dim n As Long
        Dim l As Double
        Dim t As Long
        Dim h As String
        Dim d As Double
        Dim s As Double
        Dim x As Double
        Application.ScreenUpdating = False
        Set ws = ActiveSheet
        m = ws.Cells(1, 1).End(xlDown).Row
        n = ws.Cells(1, 1).End(xlToRight).Column
        l = ws.Cells(2, 8).Value / 2
        Set wt = Worksheets.Add(After:=ws)
        For r = 2 To m
            h = ws.Cells(r, 1).Value
            d = ws.Cells(r, 2).Value
            x = 0
            c = 3
            Do While ws.Cells(r, c).Value <> ""
                s = ws.Cells(r, c).Value
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = x
                wt.Cells(t, 3).Value = s - l
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = s - l
                wt.Cells(t, 3).Value = s + l
                wt.Cells(t, 4).Value = ws.Cells(1, c).Value
                x = s + l
                c = c + 1
            Loop
            If d > x Then
                t = t + 1
                wt.Cells(t, 1).Value = h
                wt.Cells(t, 2).Value = x
                wt.Cells(t, 3).Value = d
            End If
        Next r
        Application.ScreenUpdating = True
    End Sub
    • Alexgreggio's avatar
      Alexgreggio
      Copper Contributor
      Thank you Hans!!
      I have tried it and it works like a charm! I might a few questions as I play along with it but at the moment it does exactly what I wanted! Thank you so much!!

Resources