this is a recursive sub that will read an array of titles and draw them with borders in excel sheet
the array can have as many sub array you want (that is what recursive is for)
You must have an excel page called "test"
Go in macros, ALT F11
New module
Insert this code
note:
when fndallcol is = 1 the sub will be run to find columns names only
and number of columns in the same process
we will need the number of columns later to process the data that is under all thoses titles
there is 2 catagories in the arrays, "dummy" and "filtres". They are special
Dummy will not display
filtres will have a green cell with a green border under it to be able to apply a filter on thoses columns
So dummy and filtres are reserved words you must not use in the array for titles or any sub arrays
----- code ---------
'=== insert a button in a cell
Dim aracol(30)
Sub genmanualdf_dyn()
'====== generate manual - df page
'=== recursive sub for title and sub titles etc.
'=== dynamic for page reconstruction and references variables
'=== object oriented
'=== inbounds
'=== bar to check the columns we want to activate
'=== titles and sub titles (array with array in it)
'=== titles limitations: all titles first letters must be unique and verified so the column name can be unique too to access data
'=== example: p&id number will become PIN, the columns under it will become PN TITLE
'=== possibility of an empty column for better visual page setup
'=== keyword filter reserved for filter columns (filtres)
'=== outbound
'=== border around all title, sub titles etc.
'=== initials of the title over the line, for the line under, infinitly, so column name can stay uniques
'=== button to add a new element at the end of the table (checking if all columns are empty to get at the end)
'=== green border around filters box, to inform user he can type something there
'=== filters box active cell programmed to execute a sub after cell modification (put code in notepad? or windows buffer?)
'=== notification bubble in excel as comment or something like that, check of the usual notification bubble can be used
'=== get array full for titles and columns names
Call inivar
'=== aracol(2) = page 2 (manual - df)
'=== y and x starting points
ysta = 4
xsta = 4
'=== y and x sources points (sometimes we generate a destination page so we need to identify source and destination)
ysou = ysta
xsou = xsta
'=== first part is not recursive, we only generate column check mark to activate columns for further use
'=== green squares with "check mark" for activated, dark green squares with x for not activated
'=== must generate a new array with only columns name in it, we have to go for a recursive sub right now
'=== this new array will tell us how many column exist for real, if we remove all the titles over the columns names
'=== this sub will be the same as the one that will build the table of titles and sub titles
'=== but it will return an array with all column names if we call it readonly (parameter)
' array
' param1: find columns names and return them in an array
' param2: sheet in wich to draw the titles and sub titles with borders
Set she01 = ActiveWorkbook.Worksheets("test")
prefix = ""
ara02 = Array("all columns names will end up here, will redim it to get more")
totcol = 0
'=== level of recursiveness, when we come back to 0 we reset prefix column name
lev = 0
maxlev = 0
'=== just find the columns names, no title
fndallcol = 1
aracol(2) = Array( _
"dummy", Array("REV."), "FILTRES", Array("MECH. FILTER", "ELEC. FILTER"), "", "ITEM #", "P&ID NUMBER", Array("MAIN", "SUB"), _
"SIGNAL FUNCTION DESCRIPTION", "PROCESS LOOP GROUP NAME", _
"INSTRUMENT RANGE", Array("UNIT", "MIN", "SP OR SET / RESET", "MAX"), "INSTRUMENT SUGGESTED SETTING", _
Array("UNIT", "MIN", "SP OR SET / RESET", "MAX"), "NOTE")
'=== the sub must be called once with fndallcol to find columns names and max sub level of arrays for display purposes in excel
Call subtit(aracol(2), fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat)
'=== erase sheet if its a test
lasrow = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
LasCol = she01.UsedRange.Columns(she01.UsedRange.Columns.Count).Column
Set rng01 = Range(she01.Cells(1, 1), she01.Cells(lasrow, LasCol))
If LCase(she01.Name) = "test" Then
rng01.Value = ""
rng01.ClearFormats
End If
prefix = ""
ara02 = Array("all columns names will end up here, will redim it to get more")
totcol = 0
'=== level of recursiveness, when we come back to 0 we reset prefix column name
lev = 0
'=== just find the columns names, no title
fndallcol = 0
'Call subtit(aracol(2), fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat, rngstay, rngstax)
Call subtit(aracol(2), fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat)
msg = UBound(ara02) + 1 & vbCrLf
For Each a In ara02
msg = msg & a & vbCrLf
Next
msg = msg & vbCrLf & maxlev
'MsgBox (msg)
she01.Cells(1, 1).Value = maxlev
End Sub
Sub subtit(ara01, fndallcol, she, prefix, ara02, totcol, lev, maxlev, y, x, cat)
'=== this will browse through all array and sub arrays and return an array with the column names in it
'=== a variable will contain the initials of the main title or multiples main titles for recursiveness
maxara = UBound(ara01)
For araele = 0 To maxara
a = ara01(araele)
If Not IsArray(a) Then
ReDim Preserve ara02(totcol)
If lev = 0 Then
ara02(totcol) = a
'MsgBox (prefix & vbCrLf & a)
prefix = ""
Else
ara02(totcol) = prefix & a
End If
'=== build prefix for next sub title
'=== split main title to get first letter of each word
aratmp = Split(a, " ")
allprefix = ""
For Each pre In aratmp
'=== get first letter of each word to make a prefix
allprefix = allprefix & Mid(pre, 1, 1)
If LCase(pre) = "filtres" Or LCase(pre) = "dummy" Then
allprefix = a
End If
Next
'=== add the main title prefix to the column name to make it unique
If araele + 1 <= maxara Then
If IsArray(ara01(araele + 1)) Then
'=== this is a title, border start here
'=== must be displayed as y+maxlev-lev-1
prefix = prefix & allprefix & " "
'=== we only want column names
If fndallcol = 1 Then
'=== so we do not keep a main title that have sub titles
totcol = totcol - 1
End If
If fndallcol = 0 Then
'=== title position y is higher
cat = LCase(a)
If InStr(LCase(a), "filtres") <> 0 Then
ElseIf InStr(LCase(a), "dummy") <> 0 Then
Else
cat = ""
End If
If cat <> "dummy" Then
she.Cells(y + lev, x + totcol).Value = a
rngstay = y + lev
rngstax = x + totcol
End If
tit = 1
End If
'=== we do not want the main title, we only want columns names
If fndallcol = 0 Then x = x - 1
Else
tit = 0
End If
Else
tit = 0
End If
'=== not a title, no sub array after it
If fndallcol = 0 And tit = 0 Then
'=== title without any sub titles
she.Cells(y + maxlev, x + totcol).Value = a
If a <> "" Then
If cat = "dummy" Then yoff = -1 Else yoff = 0 '=== if dummy, border will be higher cause no title is displayed
Call rngfor(Range(she.Cells(y + maxlev, x + totcol), she.Cells(y + lev + yoff, x + totcol)), 1, 3, 0, 0)
If cat = "filtres" Then
Call rngfor(Range(she.Cells(y + maxlev, x + totcol), she.Cells(y + lev + yoff, x + totcol)), 1, 3, 0, 12)
End If
End If
End If
totcol = totcol + 1
Else
lev = lev + 1
'=== remember the max array sub level for display in excel
If fndallcol = 1 Then
If lev > maxlev Then maxlev = lev
End If
Call subtit(a, fndallcol, she, prefix, ara02, totcol, lev, maxlev, y, x, cat)
cat = ""
If rngstay <> 0 And rngstax <> 0 Then
Call rngfor(Range(she.Cells(rngstay, rngstax), she.Cells(y + lev, x + totcol - 1)), 1, 3, 0, 0)
End If
End If
Next
lev = lev - 1
prefix = ""
End Sub
--------- end code
No comments:
Post a Comment