Database maker

In last post we were talking about how to distinguish between type of variables. From there, we can try to see if for any given table we can extract characteristics and mount a functional analysis of the database from a sample set of the table. For that to be achieved, something like the following Database analyser can be used. It will also detect link to Names so data can be restricted to some sources. Note: it needs the functions from this post.
Option Explicit
Private Const g_Base As Long = 0

Private Sub sDataBase_Analyzer()
' Given a database table, characterize the fields
    Dim rgTable As Excel.Range
    Dim rgHeaders As Excel.Range
    Dim rgColumn As Excel.Range
    Dim oCell As Excel.Range
    Dim oCellLinked As Excel.Range
Dim rgFormulas As Excel.Range
Dim oName As Excel.Name
Dim bName As Boolean
    Dim bHeaders As Boolean
    Dim aField() As String
    Dim aCarrousel() As String
    Dim lgField As Long
    Dim strField As String
    Dim lgDeclaration As Long
    Dim lgDeclarationOld As Long
    Dim lgItem As Long
    Dim lgCarrousel As Long
    Dim bCarrousel As Boolean

    Set rgTable = Selection 'Application.InputBox(Prompt:="Select table", Title:="", Type:=8, Default:="$A$1")
    If vbYes = VBA.MsgBox("Table has headers?", vbYesNo, "Headers on first row?") Then bHeaders = True

    ReDim Preserve aField(g_Base To rgTable.Columns.Count - 1 + g_Base)

    lgField = g_Base - 1
    If bHeaders Then
        Set rgHeaders = rgTable.Rows(1)
        For Each oCell In rgHeaders.Columns.Cells
            If Not IsEmpty(oCell) Then
                lgField = lgField + 1
                strField = VBA.Trim$(oCell.Value2)
                strField = VBA.Replace$(strField, " ", "_")
                aField(lgField) = strField

                ' Capitalize string...
'.............ToDo
            End If
        Next oCell
    End If

    lgField = g_Base - 1
    For Each rgColumn In rgTable.Columns
        lgDeclaration = 0
        If Not IsEmpty(rgColumn.Value2(1, 1)) Then
            lgField = lgField + 1
            lgCarrousel = g_Base - 1
            For Each oCell In rgColumn.Cells
                If (bHeaders And oCell.Row = rgHeaders.Row) Then
                    lgDeclarationOld = VarDeclaration(oCell.Offset(1, 0).Value2)
                Else
                    If Not IsEmpty(oCell) Then
                        lgDeclaration = VarDeclaration(oCell.value)
                        If VBA.Abs(lgDeclarationOld) < VBA.Abs(lgDeclarationOld) Then
                            If lgDeclarationOld = 32768 Then
                                aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
                                Exit For
                            End If
                        ElseIf Not bHeaders Then
                            If VBA.Abs(oCell.value) >= 32768 Then
                                aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
                                Exit For
                            End If
                        End If
                    Next oCell

                Case Is = 2
                    aField(lgField) = aField(lgField) & " As Double"

                    ' Find typical values:
                    For Each oCell In rgColumn.Cells
                        If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
                            If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
                                aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
                                Exit For
                            End If
                        ElseIf Not bHeaders Then
                            If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
                                aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
                                Exit For
                            End If
                        End If
                    Next oCell

                Case Is = 3
                    aField(lgField) = aField(lgField) & " As Date"

                Case Is = 4
                    aField(lgField) = aField(lgField) & " As String"

                    On Error Resume Next
                    Set rgFormulas = rgColumn.SpecialCells(xlCellTypeFormulas).Cells
                    On Error GoTo 0

                    If Not rgFormulas Is Nothing Then  ' Links to somewhere else
                        For Each oCell In rgColumn.SpecialCells(xlCellTypeFormulas).Cells
                            If oCell.Precedents.Count = 1 Then
                                Set oCellLinked = oCell.Precedents.Item(1)
                                For Each oName In oCell.Parent.Names
                                    If Not Intersect(oCell.Precedents.Item(1), oName.RefersToRange) Is Nothing Then
                                        If Not oName.Name Like "*_FilterDatabase" Then
                                            If oName.RefersToRange.Columns.Count = 1 Then
                                                bName = True ' --> oName.Name
                                                Exit For
                                            End If
                                        End If
                                    End If
                                Next oName
                            End If
                            If bName Then
                                Debug.Print oName.Name
                                Exit For
                            End If
                        Next oCell
                        Set rgFormulas = Nothing

                    Else
                        ' Find validation list
                        lgCarrousel = g_Base
                        ReDim Preserve aCarrousel(g_Base To lgCarrousel)
                        aCarrousel(lgCarrousel) = rgColumn.Value2(1, 1)
                        For Each oCell In rgColumn.Cells
                            If VBA.Abs(lgDeclaration) = 4 Then 'String
                                If IsBoolean(oCell.Value2) Then
                                    aField(lgField) = VBA.Replace$(aField(lgField), " As String", " As Boolean")
                                    Exit For

                                ElseIf Not (Not aCarrousel) Then
                                    bCarrousel = False
                                    For lgItem = LBound(aCarrousel) To UBound(aCarrousel)
                                        If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
                                            If aCarrousel(lgItem) = oCell.Value2 Then
                                                bCarrousel = True
                                                Exit For
                                            End If
                                        End If
                                    Next lgItem
                                Else
                                    bCarrousel = True
                                End If

                                If (bHeaders And Not (oCell.Row = rgHeaders.Row)) Or Not bHeaders Then
                                    If Not bCarrousel Then
                                        If Not IsEmpty(oCell.Value2) Then
                                            lgCarrousel = lgCarrousel + 1
                                            ReDim Preserve aCarrousel(g_Base To lgCarrousel)
                                            aCarrousel(lgCarrousel) = oCell.Value2
                                        End If
                                    End If
                                End If
                            End If
                        Next oCell

                        ' Find validation list
                        If bHeaders Then
                            If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) + 1 Then
                                Debug.Print VBA.Join(aCarrousel(), "/")
                            End If
                        Else
                            If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) Then
                                Debug.Print VBA.Join(aCarrousel(), "/")
                            End If
                        End If
                    End If

                Case Is = -1: aField(lgField) = aField(lgField) & "() As Long"
                Case Is = -2: aField(lgField) = aField(lgField) & "() As Double"
                Case Is = -3: aField(lgField) = aField(lgField) & "() As Date"
                Case Is = -4: aField(lgField) = aField(lgField) & "() As String"
            End Select
        End If
    Next rgColumn
Stop

    Debug.Print VBA.Join(aField(), vbNewLine)
End Sub

Public Function VarDeclaration(ByVal strVarCheck As String) As Long ' String
    If IsLong(strVarCheck) Then
        VarDeclaration = 1 'Long/Integer/Byte
        If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -1 ' Is array
    ElseIf IsDouble(strVarCheck) Then
        VarDeclaration = 2 'Double/Single
        If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -2 ' Is array
    ElseIf IsDate(strVarCheck) Then
        VarDeclaration = 3 'Date
        If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -3 ' Is array
    ElseIf IsString(strVarCheck) Then
        VarDeclaration = 4 'String
        'If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -4 ' Is array
    End If

End Function
[/sourcecode]

Leave a Reply

Your email address will not be published. Required fields are marked *