Attribute VB_Name = "Module1"
Const ProgID = "MYRLIN#1 1.01"

Sub MakeStandTable()
'----------------------------------------------------------------
'Produces a summary stand table by species groups from forest
'inventory data and a species list.
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'
'Revision history:
'  1-Nov-01    Plot area of -1 allows point sample data
'----------------------------------------------------------------
'
'************ variable declarations ************
Dim Dclass As Variant       'list of diameter class lower bounds
Dim Mdc As Integer          'number of diameter classes
Dim Spl As Worksheet        'species list sheet
Dim Inv As Worksheet        'inventory data sheet
Dim Tbl As Worksheet        'stand table output sheet
Dim Ash As Worksheet        'sheet with areas
Dim kStr As Integer         'column with stratum id
Dim kBlk As Integer         'column with block id if stock survey data
Dim kPlt As Integer         'column with plot id
Dim kDbh As Integer         'column with dbh
Dim kSpp As Integer         'column with species codes (data sheet)
Dim kSpl As Integer         'column with species codes (species sheet)
Dim kGrp As Integer         'column with group ID
Dim Grps As Variant         'species group codes
Dim Ng As Integer           'number of groups
Dim k As Integer            'a cell column index
Dim j As Integer            'a cell row index
Dim d As Single             'a diameter value
Dim i As Integer            'a diameter class index
Dim L As Integer            '1 for stock tree, 2 for plot tree
Dim np As Integer           'plot count within a stratum
Dim r As Integer            'output row index
Dim r0 As Integer           'initial output row for a table
Dim spp As String           'species code
Dim spg As String           'species group code
Dim g As Integer            'a group index
Dim StTab() As Double       'internal stand table for a stratum
Dim AreaB As Double         'block area for stock survey data
Dim AreaP As Double         'main plot area, ha
Dim AreaS As Double         'sub-plot area
Dim DiamL As Single         'diameter limit
Dim nV As Integer           'variable type to accumulate
Dim Awt As Double           'trees per ha represented by one tree
Dim kAwt As Integer         'area weight column for point sampling
Dim StockData As Boolean    'true if Stock survey data found
Dim ErrN As Integer         'error number
Application.StatusBar = ProgID
'************ option settings ************
Sheets("Options").Activate
Set Spl = Sheets([b3].Text)
Set Inv = Sheets([b5].Text)
Set Tbl = Sheets([b14].Text)
Set Ash = Sheets("Areas")
'column settings for data and species list
kGrp = [b4]
kStr = [b6]
kPlt = [b7]
kSpp = [b8]
kDbh = [b9]
AreaP = [b10]
AreaS = [b11]
DiamL = [b12]
kAwt = [b16]
'set variable type N=N/km, H=N/ha, G=BA/ha
nV = InStr("NHG", Left(UCase([b13].Text), 1))
If nV < 1 Then nV = 1
'************ main program code ************
'read diameter class settings from StandTable sheet
Tbl.Activate
Dclass = GetClasses([c2])
Mdc = UBound(Dclass)
'ensure data sheet sorted by stratum and plot
Inv.UsedRange.Sort key1:=Inv.Cells(1, kStr), key2:=Inv.Cells(1, kPlt), header:=xlYes
'clear output sheet
r = Tbl.UsedRange.Rows.Count
If r > 2 Then
    Tbl.Range(Tbl.Cells(3, 1), Tbl.Cells(r, Mdc + 2)).ClearContents
End If
Select Case nV
Case 1
Tbl.Cells(1, 3) = "Tree numbers per km2 by diameter classes"
Case 2
Tbl.Cells(1, 3) = "Tree numbers per ha by diameter classes"
Case 3
Tbl.Cells(1, 3) = "Basal area (m2/ha) by diameter classes"
End Select
'work through to end of data
j = 2: r = 3
ReDim StTab(1 To 2, 1 To Mdc, 1 To 1)
Do While Inv.Cells(j, kStr) > ""
    'get current tree data and add to internal table
    spp = Inv.Cells(j, kSpp)
    'lookup species code - handle error if missing
    On Error Resume Next
    spg = WorksheetFunction.VLookup(spp, Spl.UsedRange, kGrp, False)
    ErrN = Err.Number
    On Error GoTo 0
    'only process trees with valid species lookups
    If ErrN = 0 Then
        g = FindA(spg, Grps)
        If g > UBound(StTab, 3) Then
            ReDim Preserve StTab(1 To 2, 1 To Mdc, 1 To g)
        End If
        d = Inv.Cells(j, kDbh)
        'get area weight according to sampling design
        'if no plot code, then this is a stock tree
        If Inv.Cells(j, kPlt).Text = "" Then
            Awt = 1
            L = 1
            StockData = True
        Else
            If AreaP > 0 Then
                'sample plot data - area weight depends on sub-plot
                L = 2
                If d < DiamL Then Awt = 1 / AreaS Else Awt = 1 / AreaP
            Else
                'point sampling data - area wight column must be filled in
                L = 2
                Awt = Inv.Cells(j, kAwt)
            End If
        End If
        'convert area factor according to variable type
        Select Case nV
        Case 1
            Awt = Awt * 100         'N/km2
        Case 3
            Awt = Awt * d ^ 2 * 0.00007854  'BA/ha
        End Select
        'add tree to each applicable class
        For k = 1 To Mdc
            If IsArray(Dclass(k)) Then
                'normal diameter class
                If d >= Dclass(k)(0) And d < Dclass(k)(1) Then
                    StTab(L, k, g) = StTab(L, k, g) + Awt
                End If
            Else
                'cumulative diameter class
                If d >= Dclass(k) Then
                    StTab(L, k, g) = StTab(L, k, g) + Awt
                End If
            End If
        Next k
    End If
    'if next row is a different plot, increment plot counter
    If Inv.Cells(j, kPlt) <> Inv.Cells(j + 1, kPlt) Or _
        Inv.Cells(j, kStr) <> Inv.Cells(j + 1, kStr) Then np = np + 1
    'if next row is a different stratum, output and reset table
    If Inv.Cells(j, kStr) <> Inv.Cells(j + 1, kStr) Then
        'get area of stratum if required
        If StockData Then
            AreaB = WorksheetFunction.VLookup(Inv.Cells(j, kStr), Ash.UsedRange, 3, False)
        End If
        'adjust stand table for plot count and stock survey area
        Ng = UBound(Grps) + 1
        For g = 1 To Ng
            For k = 1 To Mdc
                'convert plot stand table totals to averages
                If np > 0 Then
                    StTab(2, k, g) = StTab(2, k, g) / np
                End If
                'add in stock data corrected for area
                If StockData And AreaB > 0 Then
                    StTab(1, k, g) = StTab(1, k, g) / AreaB
                    StTab(2, k, g) = StTab(2, k, g) + StTab(1, k, g)
                End If
            Next k
        Next g
        'write stratum code
        Tbl.Cells(r, 1) = Inv.Cells(j, kStr)
        r0 = r
        'write table cells
        For g = 1 To Ng
            Tbl.Cells(r, 2) = Grps(g - 1)
            For k = 1 To Mdc
                Tbl.Cells(r, k + 2) = StTab(2, k, g)
            Next k
            r = r + 1
        Next g
        'sort by alpha order of groups
        Tbl.Range(Tbl.Cells(r0, 2), Tbl.Cells(r, Mdc + 2)).Sort _
            key1:=Tbl.Cells(r0, 2), header:=xlNo
        'reset groups and stand table arrays
        Grps = Null
        np = 0
        ReDim StTab(1 To 2, 1 To Mdc, 1 To 1)
    End If
NextLine:
    j = j + 1
Loop
End Sub

Private Function FindA(e As String, a As Variant) As Integer
'----------------------------------------------------------------
'Searches for index of item e in array a and returns its
'index.  Adds it to the list if not already in.
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'----------------------------------------------------------------
Dim i As Integer
If Not IsArray(a) Then
    'list not yet started - add e as first item
    a = Array(e)
    FindA = 1
Else
    For i = 0 To UBound(a)
        If a(i) = e Then
            FindA = i + 1
            Exit Function
        End If
    Next i
    'not yet in list - add it
    i = UBound(a) + 1
    ReDim Preserve a(i)
    a(i) = e
    FindA = i + 1
End If
End Function

Private Function GetClasses(cell As Range) As Variant
'----------------------------------------------------------------
'Sets diameter classes in a range of cells according to protocol:
'  a-b  converted to array(a,b)
'  a+   converted to scalar a
'Reads across from <cell> of active sheet until blank encountered.
'Halts with error message if invalid diameter class encountered.
'
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'----------------------------------------------------------------
Dim ClassSpec As Range      'range of cells to right of <cell>
Dim ThisCell As Variant     'current cell being examined
Dim Classes As Variant      'array of class specs
Dim a As Integer, b As Integer  'class bounds decoded in cell
Dim k As Integer            'position of - or + character in cell text
Dim j As Integer            'class index
Dim nc As Integer           'class count
Set ClassSpec = Range(cell, cell.End(xlToRight))
nc = ClassSpec.Columns.Count
Classes = Array()
ReDim Classes(1 To nc)
For Each ThisCell In ClassSpec
    k = InStr(ThisCell.Text, "-")
    If k > 0 Then
        'normal diameter class range
        a = 20000: b = 0
        On Error Resume Next
        a = CInt(Left(ThisCell.Text, k - 1))
        b = CInt(Mid(ThisCell.Text, k + 1)) + 1
        On Error GoTo 0
        If b <= a Then GoTo BadClassSpec
        j = j + 1
        Classes(j) = Array(a, b)
    Else
        k = InStr(ThisCell.Text, "+")
        If k > 0 Then
            'cumulative diameter class lower bound
            a = 0
            On Error Resume Next
            a = CInt(Left(ThisCell.Text, k - 1))
            On Error GoTo 0
            If a <= 0 Then GoTo BadClassSpec
            j = j + 1
            Classes(j) = a
        Else
            GoTo BadClassSpec
        End If
    End If
Next ThisCell
'return list of class bounds
GetClasses = Classes
Exit Function
BadClassSpec:
    MsgBox "Bad diameter class specification at " + _
    ThisCell.Address + ": '" + ThisCell.Text + "'", _
    vbExclamation + vbOKOnly, "MYRLIN stand table tool"
    ThisCell.Select
    End
End Function

Sub StratumRecordCount()
'This macro counts the records in each stratum and writes
'the counts to the Areas table in column B.  It will list all
'the strata encountered in column A.
Dim Inv As Worksheet       'inventory data sheet
Dim kSt As Integer         'column with stratum id on Inv sheet
Dim StList() As String     'stratum list
Dim StRecs() As Integer    'count of stratum records
Dim Nst As Integer         'number of stratum
Dim k As Integer           'a stratum index
Dim j As Long              'a cell row index on the Inv sheet
Dim r As Long              'a cell row index on the Areas sheet
Dim Lr As Long             'last row of a range

'(1) read Options for inventory data sheet and stratum column
Sheets("Options").Activate
Set Inv = Sheets([b5].Text)
kSt = [b6]

'(2) read existing Stratum Ids (if any) and reset counts
Sheets("Areas").Activate
Lr = Cells(1, 1).End(xlDown).Row
If Lr > 1 And Lr < 65536 Then
   Nst = Lr - 1
   ReDim StList(1 To Nst), StRecs(1 To Nst)
   For r = 2 To Lr
      If Trim(Cells(r, 1).Text) = "" Then Exit For
      k = r - 1
      Nst = k
      ReDim Preserve StList(1 To Nst), StRecs(1 To Nst)
      StList(k) = Trim(Cells(r, 1).Text)
      Cells(r, 2).ClearContents
   Next r
End If

'(3) read data until blank stratum field encountered
j = 2
Do While Trim(Inv.Cells(j, kSt).Text) > ""
   'find the stratum in the list
   For k = 1 To Nst
      If Trim(Inv.Cells(j, kSt).Text) = StList(k) Then
         StRecs(k) = StRecs(k) + 1
         Exit For
      End If
   Next k
   If k > Nst Then
      'stratum not found - add it
      Nst = Nst + 1
      ReDim Preserve StList(1 To Nst), StRecs(1 To Nst)
      StList(Nst) = Trim(Inv.Cells(j, kSt).Text)
      StRecs(Nst) = 1
      k = Nst
      'update display for new stratum
      Cells(k + 1, 1) = StList(Nst)
   End If
   'update display with counts
   Cells(k + 1, 2) = StRecs(k)
   j = j + 1
Loop

End Sub