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
