recursiveness vbs array to sql

recursiveness vbs array to sql

i always wanted to convert a jagged array to a sql database
i did it

first a jagged array is an array with array inside it
example:
ara01 = array("subject01", array("sub subject 01", "sub subject 02"))

the vbs jagged array to sql converter will:
initialise global variables for a recursive script
browse throught all elements
process the element if its not an array
call itself if a sub array is found
create a sql element (row) for each element in array, related to the array before
all that with a column unique ID in sql
all that in one table

(will post code later, it's late)

excel table management with data in other sheet

"nouvel instrument"
will pop a form to choose a new instrument
the full list of instruments is in sheet "list01"
the actual list is in sheet list03_instruments
the page will generate itself with list03 and make a nice page layout (titles, borders etc)

"delete"
will delete the element from a sheet, then regenerate this whole sheet



Working on excel again, trying to clean code and making it more object to reuse it in other table

so far all this is working, delete, insert etc
but i need to resuse the code with other sheet
so i must transform all this into a sub, passing more parameters, making it more object

i must also use a standard to name my variable and sub

initial code:

(sheet)

Private Sub Worksheet_Change(ByVal Target As Range)

Call inivar

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Call checkbox(Target, Cancel)

End Sub

(this workbook)

Private Sub Workbook_Open()

Call inivar

End Sub

(module 1)


'=== insert a button in a cell
Dim aracol(30)
Public rnglist01 As Range

Sub genmanualdf()
'====== 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

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'=== aracol(2) = page 2 (manual - df)
'=== y and x starting points
Const ysta = 5
Const xsta = 4

'=== first call is to generate column name (ara02)
'=== this new array will tell us how many column exist for real, if we remove all the titles over the columns names
'=== will be used to generate check mark to activate columns for further use (generate another table)
'=== green squares with "check mark" for activated, dark green squares with x for not activated

' 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("manual - df")

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
chkmarflg = 0

'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=1
'=== to find columns names
'=== to find max sub level of arrays for display purposes in excel

'================================= column names and count max level of sub titles
Call subtit(aracol(2), fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat, rngstachkx, chkmarflg)
'=== keep number of columns (not dummy or filtres)
maxcol = totcol

'=== keep maximum number of columns that are valid (can be checked and have data in it)

'=== keep maxlev (defaut is to keep it anyway)

msg = UBound(ara02) + 1 & vbCrLf
For Each a In ara02
    msg = msg & a & vbCrLf
Next
msg = msg & vbCrLf & maxlev
'=== display column names only
'MsgBox (msg)

'=== erase sheet if its a test
lasrow = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
LasCol = she01.UsedRange.Columns(she01.UsedRange.Columns.Count).Column

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
rngstachkx = 0
chkmarflg = 1

'=================================== titles, checkbox, filtres box
Call subtit(aracol(2), fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat, rngstachkx, chkmarflg)
'=== keep first column (not dummy or filtres)
mincol = rngstachkx
'=== define click zone to select columns
'MsgBox (rngstachkx & vbCrLf & xsta + totcol)

maxcolval = totcol - rngstachkx - 1

'=== range creation for double click x or check mark to select columns we want in other sheet
Set rng02 = Range(Cells(ysta - 1, rngstachkx), Cells(ysta - 1, xsta + totcol - 1))

If chkmarflg <> 0 Then
    nomlis = "mychecks"
    '=== delete old list name (cannot overwrite it)
    For Each a In ThisWorkbook.Names
       If LCase(a.Name) = LCase(nomlis) Then
          ThisWorkbook.Names(nomlis).Delete
       End If
    Next
    '=== add list
    '=== will be used when you double click
    '=== if the double click is used in this range, we will change the checkmark from x to "check" or reverse
    '=== in this sub we will check range intersect (if the click was made in this range: Sub checkbox(ByVal Target As Range, Cancel As Boolean)

    ThisWorkbook.Names.Add Name:=nomlis, RefersTo:=rng02, Visible:=True
End If
'=== add this in sheet macro for double click management:
'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'   Call checkbox(Target, Cancel)
'End Sub

'=== last row will have double heigh and line return automatic for each column
'=== from y+maxlev,xsta to y+maxlev,x+totcol-1
she01.Rows(ysta + maxlev).RowHeight = 12.75 * 2
she01.Rows(ysta).RowHeight = 12.75 * 2
'=== auto align, line feed, this range (all row and lines)

'MsgBox (ysta & vbCrLf & xsta & vbCrLf & ysta + maxlev & vbCrLf & xsta + totcol - 1)
Set rngtmp = Range(she01.Cells(ysta, xsta), she01.Cells(ysta + maxlev, xsta + totcol - 1))
rngtmp.Columns.AutoFit
rngtmp.Cells.WrapText = True
'rngtmp.Rows.AutoFit

'================================== DATA

Set shesou01 = ActiveWorkbook.Worksheets("list03_instruments")
Set shesou02 = ActiveWorkbook.Worksheets("list02")
Set shedes = ActiveWorkbook.Worksheets("manual - df")

'=== get all data to display in manual - df, including note related
'=== source sheet (list01)
xsou = 2
ysou = 2

'=== start after the titles
ydes = ysta + maxlev + 1
'=== start after dummy and filtres
xdes = mincol

'=== delete all data and more
lasrowdes = shedes.UsedRange.Rows(shedes.UsedRange.Rows.Count).Row
lascoldes = shedes.UsedRange.Columns(shedes.UsedRange.Columns.Count).Column
Set rngtmp = Range(shedes.Cells(ydes, xdes), shedes.Cells(lasrowdes, lascoldes))
rngtmp.Value = ""
rngtmp.ClearFormats
rngtmp.Rows.RowHeight = 12.75

'MsgBox ("xdes " & xdes & vbCrLf & "ydes " & ydes & vbCrLf & "maxcol " & maxcol)
ysouoff = 0
ydesoff = 0
lasrowsou01 = shesou01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row

'=== copy all data and put all notes in an array
Dim ara03()

maxnot = 0
'=== Delete all button with delintrument in it
For Each a In shedes.Buttons
    If InStr(a.Name, "delintrument") Then
        shedes.Buttons(a.Name).Delete
    End If
Next

Do
    totemp = 0
    For x = 0 To maxcolval - 1
        a = shesou01.Cells(ysou + ysouoff, xsou + x).Value
        b = Trim(shesou01.Cells(ysou + ysouoff, xsou - 1).Value)
        If b <> "" Then tottmp = tottmp + 1
        '=== we copy only if line is tagged a in first column
        If b <> "" Then
            shedes.Cells(ydes + ydesoff, xdes + x).Value = a
            '=== add a delete button to delete an instrument in list03_instruments
            'Sub addbut(y, x, butnam, butdes, butsub, she)
            Call addbut(ydes + ydesoff, xdes - 1, "delintrument" & CStr(ydesoff), "Supprimer", "delbut", shedes)
        End If
    Next

    Call rngfor(Range(shedes.Cells(ydes, xdes), shedes.Cells(ydes + ydesoff, xdes + x - 1)), 1, 2, 0, 0)

    '=== if source line is not empty and the tag a is there in source
    '=== we go to next line in destination
    '=== if we dont go next line, the line will be overwrited
    If tottmp > 0 And b <> "" Then
        '=== check if we are in the NOTE column
        '=== then if it's not empty we fill an array
        a = LCase(Trim(Cells(ydes - 1, xdes + maxcolval - 1).Value))
        If a = "note" Then
            '=== note must be in last column (xsou+maxcolval-1)
            a = LCase(Trim(Cells(ydes + ydesoff, xdes + maxcolval - 1).Value))
            If a <> "" Then
            '=== if we are inb the note column, we store the note in an array
                ReDim Preserve ara03(maxnot)
                ara03(maxnot) = a
                maxnot = maxnot + 1
            End If
        End If

        ydesoff = ydesoff + 1
    End If
    ysouoff = ysouoff + 1
Loop Until tottmp = 0 Or ysouoff > lasrowsou01

'=== button to insert a new instrument
shedes.Rows(ydes + ydesoff).RowHeight = 12.75 * 2

'=== bouton insert - nouvel instrument
i = 0
Dim arabutnam()
Dim arabutdes()
Dim aradepnam()
Dim aradepcol()
Dim arashe()

ReDim Preserve arabutnam(i): ReDim Preserve arabutdes(i): ReDim Preserve aradepnam(i)
ReDim Preserve aradepcol(i): ReDim Preserve arashe(i)
arabutnam(i) = "Newinstrument"
arabutdes(i) = "Nouvel instrument"
aradepnam(i) = "instrument"
aradepcol(i) = "cccccc"
arashe(i) = Array("manual - df")

Set rng = shedes.Range(shedes.Cells(ydes + ydesoff, xdes), shedes.Cells(ydes + ydesoff, totcol - 2))

'=== delete button before creating it
For Each a In shedes.Buttons
    If a.Name = arabutnam(0) Then
        shedes.Buttons(arabutnam(0)).Delete
    End If
Next

Set btn = shedes.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
btn.Caption = arabutdes(0)
btn.OnAction = arabutnam(0)
btn.Name = arabutnam(0)

ydesoff = ydesoff + 1
'====== NOTES ======
'=== note will be done only if the note array is not empty
If Len(Join(ara03, "")) <> 0 Then
 
    '=== list02 = notes
    lasrowsou02 = shesou02.UsedRange.Rows(shesou02.UsedRange.Rows.Count).Row
 
    'MsgBox (ydes + ydesoff & vbCrLf & xdes)
    '=== source if list02 (notes)
    ysou = 2
    xsou = 1
 
    ydes = ydes + ydesoff + 1
    xdes = xdes
 
    Dim aratmp2()
    aratmp2 = Array("Note", "Description")
    'For i = 2 To (totcol - 2 - xdes)
    '    ReDim Preserve aratmp2(i)
    '    aratmp2(i) = ""
    'Next
 
    'aratmp = Array("NOTE(S)", aratmp2)
    aratmp = Array("note", "description")
    fndallcol = 0
    maxlev = 1
    chkmarflg = 0
    y = ydes
    x = mincol
 
    prefix = ""
    ara02 = Array("all columns names will end up here, will redim it to get more")
    totcol = 0
    lev = 0
    'maxlev = 0
 
    'Call subtit(araco, fndallcol, she01, prefix, ara02, totcol, lev, maxlev, ysta, xsta, cat, rngstachkx, chkmarflg)
    Call subtit(aratmp, fndallcol, shedes, prefix, ara02, totcol, lev, maxlev, y, x, cat, rngstachkx, chkmarflg)
 
    '=== merge description
    Set rngtmp = Range(shedes.Cells(ydes + maxlev, xdes + 1), shedes.Cells(ydes + maxlev, xdes + totcol - 2))
    rngtmp.MergeCells = True
    rngtmp.VerticalAlignment = xlCenter
    Call rngfor(rngtmp, 1, 3, 0, 0)
 
    ydes = ydes + maxlev + 1
 
    ysouoff = 0
 
    '=== check if we find "note" in the source to be sure we are at the right row and column
    a = LCase(Trim(shesou02.Cells(ysou - 1, xsou).Value))
    msg = ""
    If a = "note" Then
        '=== check all notes to find the note with same number
        '=== check if array is empty (no notes at all)
        ydesoff = 0 '=== offset to move y from row to row
     
         
        'msg = msg & note & vbCrLf
        ysouoff = 0
        Do
            a = LCase(Trim(shesou02.Cells(ysou + ysouoff, xsou)))
            If a <> "" Then
                For Each note In ara03
                    If a = note Then
                        shedes.Cells(ydes + ydesoff, xdes).Value = a
                        Set rngtmp = Range(shedes.Cells(ydes + ydesoff, xdes), shedes.Cells(ydes + ydesoff, xdes))
                        Call rngfor(rngtmp, 1, 2, 0, 0)
                     
                        a = LCase(Trim(shesou02.Cells(ysou + ysouoff, xsou + 1)))
                        shedes.Cells(ydes + ydesoff, xdes + 1).Value = a
                     
                        Set rngtmp = Range(shedes.Cells(ydes + ydesoff, xdes + 1), shedes.Cells(ydes + ydesoff, xdes + totcol - 2))
                        Call rngfor(rngtmp, 1, 2, 0, 0)
                        rngtmp.MergeCells = True
                        rngtmp.VerticalAlignment = xlCenter
                        ydesoff = ydesoff + 1
                    End If
                Next
            End If
            ysouoff = ysouoff + 1
        '=== loop until there is no number in first column of notes (list02) or at end of sheet
        Loop Until a = "" Or ysou + yoffsou > lasrowsou02
        'MsgBox (ysouoff)
        '=== align every column width from start
        Set rngtmp = Range(shedes.Cells(ysta, xdes), shedes.Cells(ydes + ydesoff - 1, xdes + totcol - 2))
        'Call rngfor(rngtmp, 1, 3, 0, 12)
     
        rngtmp.VerticalAlignment = xlTop
     
        rngtmp.Cells.WrapText = True
        rngtmp.Columns.AutoFit
    Else
        shedes.Cells(ydes, xdes).Value = "note was not found in sheet list02"
    End If
 
Else
    '=== there was 0 notes in array (arr03)
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Sub subtit(ara01, fndallcol, she, prefix, ara02, totcol, lev, maxlev, y, x, cat, rngstachkx, chkmarflg)
'=== recursive sub that call itself when it encounter an array in the array with titles

' ara01 contain titles or array of subtitles
' ara01 dummy array   = title without any subtitle without a select button
' ara01 fitlres array = array with subtitles that have a green border to enter some words to filter
' fndallcol if this = 1 then we only find all columns name, and count number of sublevel in all titles/all arrays
' she sheet name where we want to display all titles
' prefix text before a subtitle to make every column unique (not really used)
' ara02 will contain the resulting array with all columns names when fndallcol = 1
' totcol will contain the total number of columns we found when fndallcol = 1 or not
' lev level of array. if lev =3 it mean we are 3 level deep in arrays (array in array in array)
' maxlev maximum number of sub array we encountered, facilitate display in excel, as all sub array name are at bottom
' y y coordinate in excel
' x x coordinate in excel
' cat category, reserved word: dummy, filtres
' chkmarflg = 1 we will put checkmarks over the column for selectiing a column for later use

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 Or InStr(LCase(a), "dummy") <> 0 Then
                        '=== we also remove the filtres and dummy from totcol
                     
                    Else
                        cat = ""
                    End If
                    If cat <> "dummy" Then
                        If cat = "filtres" Then yoff = -1 Else yoff = 0
                        she.Cells(y + lev + yoff, x + totcol).Value = a
                        rngstay = y + lev + yoff
                        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 dummy, border will be higher cause no title is displayed
                If cat = "dummy" Then yoff = -1 Else yoff = 0
                Call rngfor(Range(she.Cells(y + maxlev, x + totcol), she.Cells(y + lev + yoff, x + totcol)), 1, 3, 0, 0)
                '=== border green if this is a "filtres" category
                If cat = "filtres" Then
                    yoff = -1
                    Call rngfor(Range(she.Cells(y + maxlev + yoff, x + totcol), she.Cells(y + lev + yoff, x + totcol)), 1, 4, &H10C010, 0)
                Else
                    yoff = 0
                End If
                '=== add a checkmark over the column to be able to select it to generate another sheet
                If cat <> "dummy" And cat <> "filtres" Then
                    If chkmarflg <> 0 Then
                        Call cheyes(y - 1, x + totcol, she)
                    End If
                    '=== remember the first x to define the checkmark zone
                    If rngstachkx = 0 Then rngstachkx = x + totcol
                    'she.Cells(y - 1, x + totcol).Value = "test"
                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, rngstachkx, chkmarflg)
        If rngstay <> 0 And rngstax <> 0 Then
            '=== if it is a filtres, we put the title higher
            If cat = "filtres" Then yoff = -1 Else yoff = 0
            '=== merge the title cells
            Set rngtmp = Range(she.Cells(rngstay, rngstax), she.Cells(y + lev + yoff, x + totcol - 1))
            rngtmp.MergeCells = True
            rngtmp.VerticalAlignment = xlCenter
            '=== border around title
            Call rngfor(rngtmp, 1, 3, 0, 0)
        End If
        cat = ""
    End If
Next

lev = lev - 1
prefix = ""

End Sub
Sub test33()



End Sub

Sub inivar()

'=== manual - df
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")

'=== vpl - vpo
aracol(3) = Array( _
"REV.", "", "P&ID NUMBER", "SIGNAL FUNCTION DESCRIPTION", "PROCESS LOOP GROUP NAME", "INSTR. SUGGESTED SETTING", _
Array("UNIT", "MIN", "SP OR     SET / RESET", "MAX"), "NOTE", "VPL", "VPO")

'Set rng02 = Worksheets("list01").Range("b2").Resize(Application.CountA(Range("$b:$b")), Application.CountA(Range("$2:$2")))
'Set rng02 = Range("b2").Resize(Application.CountA(Range("$1:$1")), Application.CountA(Range("$1:$1")))
Set she = Worksheets("list01")
Set rnglist01 = she.Range("b2").Resize(Application.CountA(she.Range("$A:$A")) - 1, Application.CountA(she.Range("$1:$1")) - 1)

End Sub
Sub Newinstrument()

Call inivar

'CreateObject("WScript.Shell").Popup "En développement" & vbCrLf & vbCrLf & "ce message disparaitra dans 2 sec", 2, "Warning"

ysou = 7
xsou = 8

Set she01 = ActiveWorkbook.Worksheets("manual - df")
she01.Activate

lasrow = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
LasCol = she01.UsedRange.Columns(she01.UsedRange.Columns.Count).Column

'=== find first empty line in table
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

xmax = xsou - 4

maxara = UBound(aracol(2))
For araele = 0 To maxara
    a = aracol(2)(araele)
    If Not IsArray(a) Then
        If araele + 1 < maxara Then
            '=== chek if the next element is an array
            arachk = aracol(2)(araele + 1)
            If IsArray(arachk) Then
                '=== if there is an array after, we dont update x
            Else
                xmax = xmax + 1
            End If
        Else
            '=== last element, so there is no array after for sure
            xmax = xmax + 1
        End If
    Else
        For Each elesubara In a
            xmax = xmax + 1
        Next
    End If
Next
'=== last column
xmax = xmax - 1

Do While ysou < lasrow
    allchk = 0
    'MsgBox (ynot & vbCrLf & xnot & vbCrLf & x1 - 1)
    For xdes = xsou To xmax
        If Trim(Cells(ysou, xdes).Value) <> "" Then allchk = allchk + 1
        'MsgBox ("test")
        'she.Cells(ynot, x2).Interior.ColorIndex = 10 'darkgreen
    Next
    ysou = ysou + 1
    If allchk = 0 Then
        Exit Do
    End If
Loop
ysou = ysou - 1

'=== open form to choose the instrument to insert

SelectProjetExl.Show



'MsgBox (ysou)

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

'=== generate the import cad page, clear all before
Sub genimportcad()

Dim rng01 As Range
Dim rng02 As Range

Call inivar

'=== CreateObject("WScript.Shell").Popup "En développement" & vbCrLf & vbCrLf & "ce message disparaitra dans 2 sec", 2, "Warning"

'=== source
Set she01 = ActiveWorkbook.Worksheets("manual - df")

'=== destination
Set she02 = ActiveWorkbook.Worksheets("import-cad")
'Set she02 = ActiveWorkbook.Worksheets("import-cad")
'.Height
'.Width

'=== select all actives cells in the sheet
lasrow = she02.UsedRange.Rows(she02.UsedRange.Rows.Count).Row
LasCol = she02.UsedRange.Columns(she02.UsedRange.Columns.Count).Column

'=== erase all content and formats
she02.Activate
Set rng01 = Range(Cells(1, 1), Cells(lasrow, LasCol))

rng01.Value = ""
rng01.ClearFormats

she02.Activate

y = 0
x = 0
'=== read x for column we want, we use the array from aracol(1) - sheet 2
Set cel01 = she02.Cells(y + 2, x + 1)
cel01.Value = "INSTRUMENTATION SETTINGS"
cel01.Font.Size = 16
Set cel02 = she02.Cells(y + 2, x + 5)
cel02.Value = "REV:"
cel02.Font.Size = 16
Set cel03 = she02.Cells(y + 2, x + 6)
cel03.Value = "FUTUR"
cel03.Font.Size = 16

Set she03 = ActiveWorkbook.Worksheets("manual - df") '=== manual - df
'=== each sheet have an array containing its columns with the same number as the sheet

'=== browse all columns to transfert them in import-cad
'=== with filters: column selected, mech, elec
Set she = she02

'=== y coordinate destination
ydes = 4
xdes = 1
'=== y coordinate destination start
ydessta = ydes
xdessta = xdes

araele = 0

'=== y coordinate source
ysou = 4
xsou = 8 '=== x from page source

ysousta = ysou
xsousta = xsou

skiptospace = 0
lasrowdat = 0
colfon01 = 0

'call subtit(ara01, fndallcol, she, prefix, ara02, totcol, lev, maxlev, y, x, cat, rngstachkx, chkmarflg)

maxara = UBound(aracol(2))
For araele = 0 To maxara
    a = aracol(2)(araele)
    If Not IsArray(a) Then
        '=== we start only after the first space in the array (but only once)
        If skiptospace <> 2 Then
            If a = "" Then
                skiptospace = 1
            Else
                '=== did not reach space yet, filters
                If araele <> 0 Then '=== not first column
                    Set rng01 = Range(she01.Cells(ysou + 1, xsou - 4 + araele), she01.Cells(ysou + 1, xsou - 4 + araele))
                    Call rngfor(rng01, 1, 3, &H10C010, 0)
                End If
                'she01.Cells(ysou + 1, xsou - 4).Interior.ColorIndex = 13 'darkgreen
            End If
            'xsou = xsou + 1
        End If
    End If
    If skiptospace = 2 Then
        lasrowshe01 = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
        '=== find last row to copy
        If lasrowdat = 0 Then
            lasrowshe01 = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
            For ydat = ysou + 3 To lasrowshe01
                aa = Trim(LCase(she01.Cells(ydat, 8).Value))
             
                If Trim(LCase(she01.Cells(ydat, 8).Value)) = "note" Then
                    lasrowdat = ydat - 1
                End If
            Next
        End If
     
        '=== we are not in sub titles
        If Not IsArray(a) Then
            '=== if the next element is an array
            '=== we must validate if at least one of the 4 sub title is checked
            chkall = 0
            If araele + 1 < maxara Then
                '=== chek if the next element is an array
                arachk = aracol(2)(araele + 1)
                If IsArray(arachk) Then
                    '=== the next element is an array
                    For isub = 0 To UBound(arachk)
                        elearasub = arachk(isub)
                        If she01.Cells(ysou, xsou + isub) = "a" Then
                            'sshe.Cells(yy, xx).Interior.ColorIndex = 10 'darkgreen
                            'she01.Cells(ysou - 1, xsou + ichk + Offset).Interior.ColorIndex = 12
                            chkall = chkall + 1
                        End If
                     
                    Next
                Else
                    '=== the element after this title is not an array, so its a normal main title
                    chkall = -1
                End If
                'chkall = -1
            Else
                '=== this is the last element of the array, so we assume there will be no subtitle after it
                chkall = -1
            End If
            '=== main title will be displayed only if at least 1 sub title is checked
            If chkall > 0 Then
                '=== title with subtitles
                she02.Cells(ydes, xdes).Value = a
                '=== define a range with this cell and the cell under it
                'Set rng02 = Range(Cells(ydes, xdes), Cells(ydes + 1, xdes))
                y0 = ydes
                x0 = xdes
                xdes = xdes + 1
                xsou = xsou + 1
            End If
            If chkall = -1 Then
                '=== normal title without sub titles
                If she01.Cells(ysou, xsou) = "a" Then
                    she02.Cells(ydes, xdes).Value = a
                    '=== this cell and the one under it
                    Set rng01 = Range(Cells(ydes, xdes), Cells(ydes + 1, xdes))
                    '=== border main title without sub title
                    Call rngfor(rng01, 1, 3, 0, colfon01)
                 
                    '=== copy data cause we are not in a sub title (sub array)
                    ''=== Sub copdat(ysou, lasrowdat, xdes, colfon01,she01, she02)
                    Call copdat(ysou, lasrowdat, xdes, colfon01, she01, she02, xsou, ysousta, xsousta)
                    xdes = xdes + 1
                End If
                xsou = xsou + 1
                'chkall = 0
            End If
        '=== SUB ARRAY =============
        Else
            If chkall > 0 Then
                '=== sub array
                xdes = xdes - 1 '=== go back 1 column cause there is a main title to every sub title
                xsou = xsou - 1
                prefix = ""
                '=== get main title
                com = she02.Cells(ydes, xdes)
                'she02.Cells(ydes, xdes) = com
                xdessubsta = xdes
                i = 0
                For Each elesubara In a

                    If she01.Cells(ysou, xsou) = "a" Then
                        'sshe.Cells(yy, xx).Interior.ColorIndex = 10 'darkgreen
                        'she01.Cells(ysou, xsou).Interior.ColorIndex = 18
                        'she02.Cells(ydes, xdes).ClearComments
                        'she01.Cells(y1, x1 + ichk + Offset).clearcomment
                        'she01.Cells(y1, x1 + ichk + Offset).AddComment b
                     
                        '=== make an acronym with main title
                        If prefix = "" Then
                            arawor = Split(com, " ")
                            For Each wor In arawor
                                '=== get first letter of each word to make a prefix
                                prefix = prefix & Mid(wor, 1, 1)
                            Next
                            prefix = prefix & " "
                        End If
                        '=== write subtitle
                        she02.Cells(ydes + 1, xdes).Value = prefix & elesubara '& "   ysou: " & ysou & "   xsou: " & xsou & "   i: " & i
                        '===
                        Set rng01 = Range(Cells(y0 + 1, x0), Cells(ydes + 1, xdes))
                            '=== border for subtitle only
                        Call rngfor(rng01, 1, 3, 0, colfon01)
                     
                        '=== copy data sub title (sub array)
                        Call copdat(ysou, lasrowdat, xdes, colfon01, she01, she02, xsou, ysousta, xsousta)
                        xdes = xdes + 1
                     
                    End If
                    xsou = xsou + 1
                 
                Next
                '=== merging cells for title
                Set rngtmp = Range(Cells(ydes, xdessubsta), Cells(ydes, xdes - 1))
                rngtmp.MergeCells = True
                rngtmp.VerticalAlignment = xlCenter
             
                '=== borders for main title that have sub titles
                Call rngfor(rngtmp, 1, 3, &H0, 12)
            Else
                '=== sub array, but no field was selected
                '=== yet we must skip the columns in the source page or all is screwed up
                For Each elesubara In a
                    xsou = xsou + 1
                Next
            End If
        End If
        '=== range with lines all around it - type - thickness - color - background
        '=== thickness 2 = thin
        '=== thickness 3 = bold
    End If
    '=== skip a space then go to next element
    If skiptospace = 1 Then
        skiptospace = 2
    End If
Next

'=== borders for all titles (main and with subs, kinda overall border)
Set rng01 = Range(Cells(ydessta, xdessta), Cells(ydessta + 1, xdes - 1))
Call rngfor(rng01, 1, 3, &H0, 0)

'=== note added at the end of the import-cad sheet ==========================
xdesend = xdes - 1 '=== last column (for border)
xdes = xdessta
ydes = lasrowdat + 1
xsou = xsousta

lasrow = she01.UsedRange.Rows(she01.UsedRange.Rows.Count).Row
she02.Cells(lasrowdat + 1, xdes).Value = "Note"

For ysou = lasrowdat + 1 To lasrow
    aa = she01.Cells(ysou, xsou).Value
    bb = she01.Cells(ysou, xsou + 1).Value
    If aa <> "" And bb <> "" Then
        'she02.Cells(ydes, xdes).Interior.ColorIndex = 18
        she02.Cells(ydes, xdes).Value = aa
        Set rng01 = Range(she02.Cells(ydes, xdes), she02.Cells(ydes, xdes))
        Call rngfor(rng01, 1, 2, &H0, 0)

        she02.Cells(ydes, xdes + 1).Value = bb
        Set rngtmp = Range(she02.Cells(ydes, xdes + 1), she02.Cells(ydes, xdesend))
        rngtmp.MergeCells = True
        rngtmp.VerticalAlignment = xlCenter
        Call rngfor(rngtmp, 1, 2, &H0, 0)

        'she01.Cells(ysou, xsou).Interior.ColorIndex = 19
        ydesend = ydes
    End If
    ydes = ydes + 1
Next

'=== border around note
Set rng01 = Range(she02.Cells(lasrowdat + 1, xdes), she02.Cells(lasrowdat + 1, xdes))
Call rngfor(rng01, 1, 3, &H0, 0)

'=== border around all first line of note
Set rngtmp = Range(she02.Cells(lasrowdat + 1, xdes + 1), she02.Cells(lasrowdat + 1, xdesend))
rngtmp.MergeCells = True
rngtmp.VerticalAlignment = xlCenter
Call rngfor(rngtmp, 1, 3, &H0, 0)

'=== border around all note
Set rng01 = Range(she02.Cells(lasrowdat + 1, xdes), she02.Cells(ydesend, xdesend))
Call rngfor(rng01, 1, 3, &H0, 0)

'=== align
Set rng01 = Range(she02.Cells(ydessta, xdessta), she02.Cells(lasrowdat, xdesend - 1))
rng01.Columns.AutoFit
rng01.Rows.AutoFit

End Sub
'=== generate the manual - df page
Sub genmanualdfold()
'=== equipement
'she.Cells(y + 3, x + 4).Value = Worksheets("registre révisions").Cells(5, 5).Value
she.Cells(y + 3, x + 5).Value = "FILTRES"
'=== projet
'she.Cells(y + 4, x + 5).Value = Worksheets("registre révisions").Cells(4, 5).Value
'=== serial number
'she.Cells(y + 4, x + 11).Value = Worksheets("registre révisions").Cells(6, 5).Value
she.Cells(y + 3, x + 9).Value = "INSTRUMENTATION SETTINGS"
she.Cells(y + 3, x + 16).Value = "REV:"
she.Cells(y + 3, x + 17).Value = "FUTUR"

'=== number of sub array (line under a line), for each sub array we skip a line

End Sub
Sub cheyes(yy, xx, sshe)
    sshe.Cells(yy, xx).HorizontalAlignment = xlCenter
    sshe.Cells(yy, xx).Font.Name = "marlett"
    sshe.Cells(yy, xx).Value = "a" '=== a = checkmark with this font
    sshe.Cells(yy, xx).Interior.ColorIndex = 4 'green
End Sub
Sub cheno(yy, xx, sshe)
    sshe.Cells(yy, xx).HorizontalAlignment = xlCenter
    sshe.Cells(yy, xx).Font.Name = "arial"
    sshe.Cells(yy, xx).Value = "x" '=== a = checkmark with this font
    sshe.Cells(yy, xx).Interior.ColorIndex = 10 'darkgreen
End Sub
Sub genvplvpo()

y = -1
x = -3

Set she = ActiveWorkbook.Worksheets("VPL - VPO")
'=== equipement
she.Cells(y + 2, x + 4).Value = Worksheets("registre révisions").Cells(5, 5).Value
she.Cells(y + 3, x + 4).Value = "ELECTRICAL PRE-DELIVERY & PRE-OPERATIONAL CHECK LIST"
'=== projet
she.Cells(y + 4, x + 5).Value = Worksheets("registre révisions").Cells(4, 5).Value
'=== serial number
she.Cells(y + 4, x + 11).Value = Worksheets("registre révisions").Cells(6, 5).Value
she.Cells(y + 7, x + 6).Value = "INSTRUMENTATION SETTINGS"

'=== number of sub array (line under a line), for each sub array we skip a line
nbrsubara = 0
x1 = 1
y1 = 8

For Each a In aracol(3)
    If Not IsArray(a) Then
        she.Cells(y1, x1).Value = a
        x1 = x1 + 1
    Else
        '=== sub array
        x1 = x1 - 1
        For Each b In a
            '=== only 1 level of array plz
            she.Cells(y1 + 1, x1).Value = b
            x1 = x1 + 1
        Next
    End If
Next

'=SI(NB.VIDE('MANUAL - DF'!D7)=1;"";'MANUAL - DF'!D7)
CreateObject("WScript.Shell").Popup "En développement - seul les titres ont été généré, les data ont pas bougé" & vbCrLf & vbCrLf & "ce message disparaitra dans 2 sec", 2, "Warning"

'she.Activate

End Sub
'=== registre révisions

Sub CreateFormsButton()

Dim btn As Button
Dim rng As Range
Dim arabutnam()
Dim arabutdes()
Dim aradepnam()
Dim aradepcol()
Dim arashe()

'=== test window notepad
test = 0
If test = 1 Then
    intF = FreeFile()
    Open "c:\aef_log.txt" For Output As intF
    'Print #intF, sSql
    'Close #intF
End If

Dim she As Excel.Worksheet
Dim pic As Object

'=== arrays with buttons name, description, departement, color
x = 0
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "NewProject"
arabutdes(x) = "Nouveau projet"
aradepnam(x) = "SEARCH"
aradepcol(x) = "cccccc"
arashe(x) = Array("manual - df", "registre révisions")

x = x + 1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "newrevision"
arabutdes(x) = "Nouvelle révision"
aradepnam(x) = "SEARCH"
aradepcol(x) = "cccccc"
arashe(x) = Array("registre révisions")

x = x + 1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "Newinstrument"
arabutdes(x) = "Nouvel instrument"
aradepnam(x) = "instrument"
aradepcol(x) = "cccccc"
arashe(x) = Array("manual - df")

x = x + 1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "genmanualdf"
arabutdes(x) = "Générer manual - DF"
aradepnam(x) = "instrument"
aradepcol(x) = "cccccc"
arashe(x) = Array("manual - df")

x = x + 1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "genimportcad"
arabutdes(x) = "Générer la feuille import-cad"
aradepnam(x) = "cad"
aradepcol(x) = "cccccc"
arashe(x) = Array("manual - df", "registre révisions")

x = x + 1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x)
ReDim Preserve aradepcol(x): ReDim Preserve arashe(x)
arabutnam(x) = "genvplvpo"
arabutdes(x) = "Générer VPL -VPO"
aradepnam(x) = "vplvpo"
aradepcol(x) = "cccccc"
arashe(x) = Array("manual - df", "registre révisions")


For Each she In ActiveWorkbook.Worksheets
    she.Activate
 
    shenam = LCase(she.Name)

 
    '=== insert image resizable with cell
    'Call insima(she, "http://intranet.stas.com/Logos%20STAS%20Unigec/Logos%20STAS/LOGO%20STAS%20BLEU-adresse.jpg")
 
    '=== delete all buttons
    she.Buttons.Delete
 
    '=== generate buttons
    y = 2
    x = 2
    y2 = 0
 
    i = 0
    hig = 60 '=== pixel height of a button
    For Each a In arabutnam
       '=== check if sheet name is in array to display this button or not
       fnd01 = 0
       For Each b In arashe(i)
          If shenam = b Or b = "all" Then fnd01 = 1
       Next
       If fnd01 = 1 Then
           Set rng = she.Range(Cells(y + y2, x), Cells(y + y2, x))
           Set btn = she.Buttons.Add(rng.Left, rng.Top, rng.Width, hig)
         
           btn.Caption = arabutdes(i)
           btn.OnAction = arabutnam(i)
         
           i2 = 0
           b = 0
           c = 0
           Do While b < 60
               b = b + Cells(y + y2 + i2, x).Height
               If b > hig * 2.2 Then Exit Do
               c = c + 1
               i2 = i2 + 1
           Loop
           y2 = y2 + c
         
        End If
        i = i + 1
    Next
 
    '=== adjust buttons height
    If fnd01 <> 0 Then
        Set rng = she.Range(Cells(y + y2 - 2, x), Cells(y + y2 - 2, x))
        rng.Columns.AutoFit
        rng.Rows.AutoFit
    End If
Next

If test = 1 Then Close #intF

End Sub
'=== insere fichier image
Sub insima(she, ficima)

'===insertion
Set pic = she.Pictures.Insert(ficima)
Set rng = she.Range(Cells(2, 4), Cells(2, 4))
 
t = rng.Top
l = rng.Left
w = rng.Offset(0, rng.Columns.Count).Left - rng.Left
h = rng.Offset(rng.Rows.Count, 0).Top - rng.Top

pic.Top = t
pic.Left = l
pic.Width = w
pic.Height = h

'pic.Select

pic.ShapeRange.LockAspectRatio = True     ' proportions d'origine lorsque vous la redimensionnez
'    Selection.Top = ActiveCell.Top           ' haut de la cellule
'    Selection.Left = ActiveCell.Left         ' gauche de la cellule
'    Selection.Height = ActiveCell.RowHeight  ' hauteur de la cellule
'    Selection.Width = ActiveCell.Width       ' largeur de la cellule
pic.PrintObject = True             ' l'objet est imprimé en même temps que le document
pic.Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules


End Sub

Sub newproject()
CreateObject("WScript.Shell").Popup "En développement" & vbCrLf & vbCrLf & "ce message disparaitra dans 2 sec", 2, "Warning"
 

End Sub
Sub newrevision()
CreateObject("WScript.Shell").Popup "En développement" & vbCrLf & vbCrLf & "ce message disparaitra dans 2 sec", 2, "Warning"

End Sub
Sub adjborcol(yy, xx)

   'Borders.LineStyle = xlThick
   lin01 = 1
   thi01 = 4
   Cells(yy, xx).Borders(xlEdgeLeft).LineStyle = lin01
   Cells(yy, xx).Borders(xlEdgeLeft).Weight = thi01
   Cells(yy, xx).Borders(xlEdgeTop).LineStyle = lin01
   Cells(yy, xx).Borders(xlEdgeTop).Weight = thi01
   Cells(yy, xx).Borders(xlEdgeBottom).LineStyle = lin01
   Cells(yy, xx).Borders(xlEdgeBottom).Weight = thi01
   Cells(yy, xx).Borders(xlEdgeRight).LineStyle = lin01
   Cells(yy, xx).Borders(xlEdgeRight).Weight = thi01
 
   '=== green
   col01 = &H10C010
   Cells(yy, xx).Borders(xlEdgeLeft).Color = col01
   Cells(yy, xx).Borders(xlEdgeTop).Color = col01
   Cells(yy, xx).Borders(xlEdgeBottom).Color = col01
   Cells(yy, xx).Borders(xlEdgeRight).Color = col01

End Sub
Sub rngfor(rrng01, lin01, thi01, col01, bac01)
 
   rrng01.Borders(xlEdgeLeft).LineStyle = lin01
   rrng01.Borders(xlEdgeLeft).Weight = thi01
   rrng01.Borders(xlEdgeTop).LineStyle = lin01
   rrng01.Borders(xlEdgeTop).Weight = thi01
   rrng01.Borders(xlEdgeBottom).LineStyle = lin01
   rrng01.Borders(xlEdgeBottom).Weight = thi01
   rrng01.Borders(xlEdgeRight).LineStyle = lin01
   rrng01.Borders(xlEdgeRight).Weight = thi01
 
   rrng01.Borders(xlInsideVertical).LineStyle = lin01
   rrng01.Borders(xlInsideVertical).Weight = thi01
   rrng01.Borders(xlInsideHorizontal).LineStyle = lin01
   rrng01.Borders(xlInsideHorizontal).Weight = thi01

   '=== green
   'col01 = &H10C010
 
   rrng01.Borders(xlEdgeLeft).Color = col01
   rrng01.Borders(xlEdgeTop).Color = col01
   rrng01.Borders(xlEdgeBottom).Color = col01
   rrng01.Borders(xlEdgeRight).Color = col01
 
   rrng01.Interior.ColorIndex = bac01
End Sub
Sub references()
'=== buttons loop all

    '=== select all actives cells in the sheet
    lasrow = she2.UsedRange.Rows(she2.UsedRange.Rows.Count).Row
    LasCol = she2.UsedRange.Columns(she2.UsedRange.Columns.Count).Column
 
    '=== old method
    Set rng01 = Range("a1", Cells(lasrow, LasCol))
    '=== all hyperlinks === Set colHli = she2.Hyperlinks

    'Private Sub CheckBox1_Click()
    'If CheckBox1.Value = True Then
    '[a3] = "10"
    'Else
    '[a3] = "11"
    'End If
    'End Sub
 
    test = 0
    If test = 1 Then
        intF = FreeFile()
        Open "c:\aef_log.txt" For Output As intF
        Print #intF, "START"
        'Close #intF
    End If

Rows("1:5").RowHeight = 30
Columns("A:E").ColumnWidth = 30

End Sub

Private Sub Workbook_Open()

'=== Call maj_table

End Sub

'=================================== workbook_sheetchange
'=== this must be put in the worksheet section of the macros
'Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'=== if a input cell is changed, we call updqate (maj)
    '   If Target.Address = "$B$4" Or Target.Address = "$B$3" Then
    '      Call maj_table
    '   End If
'end sub

'Private Sub Worksheet_Change(ByVal Target As Range)
    '=== reinitialise all zone in listXX for the forms choice list
    'Call inivar
'End Sub

'====================================

Sub checkbox(ByVal Target As Range, Cancel As Boolean)

    '=== Limit Target count to 1
    If Target.Count > 1 Then Exit Sub
    '=== Isolate Target to a specific range
    If Intersect(Target, Range("myChecks")) Is Nothing Then Exit Sub
    '=== Check value of target
    If Target.Value <> "a" Then
        Target.HorizontalAlignment = xlCenter
        Target.Font.Name = "marlett"
        Target.Value = "a" 'Sets target Value = "a"
        Target.Interior.ColorIndex = 4 'green
        Cancel = True
        Exit Sub
    End If
    If Target.Value = "a" Then
        Target.Font.Name = "arial"
        Target.ClearContents 'Sets Target Value = ""
        Target.HorizontalAlignment = xlCenter
        Target.Value = "x"
        Target.Interior.ColorIndex = 10 'dark green
        Cancel = True
        Exit Sub
    End If

'=== color index: http://dmcritchie.mvps.org/excel/colors.htm
End Sub

Sub copdat(ysou, lasrowdat, xdes, colfon01, she01, she02, xsou, ysousta, xsousta)

'Set rng01 = Range(she01.Cells(ysou + 1, xsou - 4 + araele), she01.Cells(ysou + 1, xsou - 4 + araele))
'Call rngfor(rng01, 1, 3, &H10C010, 0)

'=== chek for filters before copy data
fil01 = Trim(LCase(Cells(ysousta + 1, xsousta - 4).Value))
fil02 = Trim(LCase(Cells(ysousta + 1, xsousta - 3).Value))

For ydat = ysou + 3 To lasrowdat
    Dim rng01 As Range
    '=== stop when column 8 = note
    she02.Cells(ydat - 1, xdes).Value = she01.Cells(ydat, xsou).Value
    Set rng01 = Range(Cells(ydat - 1, xdes), Cells(ydat - 1, xdes))
    '=== border for data that have a main title
    Call rngfor(rng01, 1, 2, 0, colfon01)
Next
                     
End Sub

Sub addbut(y, x, butnam, butdes, butsub, she)
'=== bouton insert - nouvel instrument

Set rng = she.Range(she.Cells(y, x), she.Cells(y, x))

'=== delete button before creating it
For Each a In she.Buttons
    If a.Name = butnam Then
        she.Buttons(a.Name).Delete
    End If
Next

Set btn = she.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
btn.Caption = butdes
btn.OnAction = butsub
btn.Name = butnam

End Sub
Sub delbut()

'=== give us the name of the button that called this sub to delete the right intrument
butnam = Application.Caller

Set shedes = ActiveWorkbook.Worksheets("list03_instruments")

'=== extract the number at the end of button name
elenum = Right(butnam, Len(butnam) - Len("delintrument"))

'=== supress the line containing this instrument in shedes (sheet destination)

shedes.Rows(elenum + 2).EntireRow.Delete

Call genmanualdf

End Sub

(form code)

Private Sub Label1_Click()

End Sub

Private Sub listinstruments_Click()

    

    

End Sub

Private Sub UserForm_Initialize()

    

    'MsgBox ("salut")

    Dim rngtmp As Range

    Dim rngstr As String

    Dim she As Worksheet

    

    Set she = Worksheets("list01")

    Set rngtmp = rnglist01

    rngstr = she.Name & "!" & rngtmp.Address

    '=== dynamic range auto growth

    'plage = Worksheets("list01").Range(Cells(1, 1), Cells(12, 14)).Address

    'MsgBox (plage)

        '.BoundColumn = 1

        '.ColumnCount = 3

        '.ColumnHeads = True

        '.TextColumn = True

        '.RowSource = "Sheet1!A2:C" & xlLastRow("Sheet1")

        '.ListStyle = fmListStyleOption

        '.ListIndex = 0

    listinstruments.ColumnHeads = True

    listinstruments.RowSource = rngstr

End Sub

Private Sub btnContinuerSelect_Click()

    'colcnt = Range("poo").Columns.Count

    totcol = rnglist01.Columns.Count

    

    '=== insert new instrument

    Set shedes = ActiveWorkbook.Worksheets("list03_instruments")

    lasrow = shedes.UsedRange.Rows(shedes.UsedRange.Rows.Count).Row

    

    x = 1

    '=== find last empty line

    For y = 2 To lasrow

        If Trim(shedes.Cells(y, x).Value) = "" Then Exit For

    Next

    

    '=== use first column to tag as NOT empty (puttting a number in it)

    shedes.Cells(y, x).Value = y

    

    '=== insert choice in all columns in the listing sheet

    For xoffset = 0 To totcol - 1

        shedes.Cells(y, 2 + xoffset).Value = listinstruments.Column(xoffset, listinstruments.ListIndex)

    Next

    Unload Me

    Call genmanualdf

End Sub

add data from a listbox in a sheet multiple columns

okay

range for listbox is dynamic
result is inserted in a sheet that i use as a list
result from listbox is inserted in the sheet used to generate main sheet

here is the form and the click when we click continue after selecting a choice

using excel as a database with delete and insert is a pain! ;)


-------------- code in the form ------------------

Private Sub UserForm_Initialize()
   
    'MsgBox ("salut")
    Dim rngtmp As Range
    Dim rngstr As String
    Dim she As Worksheet
   
    Set she = Worksheets("list01")
    Set rngtmp = rnglist01
    rngstr = she.Name & "!" & rngtmp.Address

    '=== dynamic range auto growth
    'plage = Worksheets("list01").Range(Cells(1, 1), Cells(12, 14)).Address
    'MsgBox (plage)
        '.BoundColumn = 1
        '.ColumnCount = 3
        '.ColumnHeads = True
        '.TextColumn = True
        '.RowSource = "Sheet1!A2:C" & xlLastRow("Sheet1")
        '.ListStyle = fmListStyleOption
        '.ListIndex = 0
    listinstruments.ColumnHeads = True
    listinstruments.RowSource = rngstr

End Sub

Private Sub btnContinuerSelect_Click()
    'colcnt = Range("poo").Columns.Count
    totcol = rnglist01.Columns.Count
   
    '=== insert new instrument
    Set shedes = ActiveWorkbook.Worksheets("list03_instruments")
    lasrow = shedes.UsedRange.Rows(shedes.UsedRange.Rows.Count).Row
   
    x = 1
    '=== find last empty line
    For y = 2 To lasrow
        If Trim(shedes.Cells(y, x).Value) = "" Then Exit For
    Next
   
    '=== use first column to tag as NOT empty (puttting a number in it)
    shedes.Cells(y, x).Value = y
   
    '=== insert choice in all columns in the listing sheet
    For xoffset = 0 To totcol - 1
        shedes.Cells(y, 2 + xoffset).Value = listinstruments.Column(xoffset, listinstruments.ListIndex)
    Next
    Unload Me
    Call genmanualdf
End Sub

working on excel macro

adding a new list of all instruments
adding a delete button for each intrument
making the insert new instrument button work

now how can i tell wich delete button was pressed
they all call the same sub but are not attached to same cell borders

can i read the cell number on wich the button was attached?

mystery...

recursive multiple column and line title in excel

Finally, it's working!

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