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]