Appendix Thread. Diet Protokol Coding Adaptions

[DocAElstein]

Test and Appendix postings for adaption of my Diet Protokol Codings for sharing and support of other excelfox Threads

[DocAElstein]

_____ Workbook: ProAktuellex8600x2.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B

16672


16673


16674


16675


16676


16677


16678


16679


16680


16681


16682


16683


16684


16685


16686


16687


16688


16689


16690


16691NesClas2Suc.75g 2malZuSuß 5.4g


16692NesCals2.54NesMild20gSuc.6 2malZuSuß11g


16693NesClas1.21nesMild1.53Suc.6g6.5g


16694NesClas2.96Suc.4g 2malZuSuß7.4g


16695NesMild3.01Suc.8g Made 10_03_2019 2malZuSuß10.8g


166963.06NesClassic .9gSuc Bisy zu suß Made 17_10_20182.8g


166973.07NesClassic .4gSuc OK suß Made 17_10_20184g


166981.95NesMild NesClassic1 Suc.6g Made 17_10_20185.8g


166992.2NesClassic .6gSuc Made 25_06_2018 Bisy suß4.5g


167002G&G .5gSuc Made 25_06_2018 Bisy zu suß5g


167012.21Nes.5gSuc ZuSuß Made 05_06_20186.7g


167022.18Nes.5gSuc OKSuß Made 05_06_20185.8g


167035.54Nes.35Suc OK Made 05_06_201811.8g


167042.02Nes2.5gSuc Made 15_04_20187,9g


167051.81Nes.3gSuc Made 15_04_20187,3g


167061.6NesMild1.1gSuc Made 15_04_20187,7g


167071.9NesMild1.6gSuc Made 15_04_20189,1g


16708KakClasic210gSuc4.5g_02.01.20186.54g


16709Nes58gSuc2.5gCacPur060gCebeCac256g_21_02_2018 18g


16710Kaffe176gSuc2.5g Made 21_02_20187.7g


16711Kaffee64g cacPuro138g Suc1g SkinnySchok175g Made 21_02_201814,5g


16712Kaffee144g Cac Puro119g Suc2g Made 21_02_20189,8g


16713Kaffee184g SkinnyShoko96g Suc 2g Made 21_02_201811,3g


16714


16715


16716


16717


16718


16719


16720

16721
Worksheet: Sheet1

Typically I have sections of 50 rows which “belong together”, ( 49grouped + 1 below ) , and things may be added. It is easier to add anywhere in the section and then do a sort on the entire group, or part thereof , as required..
49grouped+1.JPG : https://imgur.com/a8rflEn
2200
The group above is 16721 ; 16722 ; 16723 .... 16672 = (16672-16721)+1 = 50 rows

[DocAElstein]

_____ Workbook: ProAktuellex8600x2.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
Y
Z
AA
AB
AC
AD
AE
AF
AG
AH
AI
AJ
AK
AL
AM
AN
AO
AP
AQ
AR
AS
AT
AU
AV
AW
AX
AY
AZ
BA
BB
BC
BD
BE
BF
BG
BH
BI
BJ
BK
BL
BM
BN
BO
BP
BQ
BR
BS
BT
BU
BV
BW
BX
BY
BZ
CA
CB
CC
CD
CE
CF
CG
CH
CI
CJ
CK
CL
CM
CN
CO
CP
CQ
CR
CS
CT
CU
CV
CW
CX
CY
CZ
DA
DB
DC
DD
DE
DF
DG
DH
DI
DJ
DK
DL
DM

1Food Produkt
Morgen
Mittag
Abend

Gruppieren Food Group Hit Me! x
Kcal

Fett

Eiweiß

Koh

Zucker

Ballastoffe

Wasser

kalium

Natrium+

Kalzium

Magnesium

chlorid

Phosphor

Schwefel

OrganischeSäuren

Alkohol

Ca2+

Mg2+

PO43-

SO42-

HCO3-



MF

Retinoläquivalent

A (Retinol)

ß-Carotin

D (Calciferol)

E (Tocopherol)



a-Tocopherol

68
69
K (Phyllochinon)
71
72
73
B1 (Thiamin)
75
B2 (Riboflavin)
77
B3 Niacin
79
Niacinäquivalent
81
B5 Panthothensäure
83
B6 (Pyridoxin)
85
B7 Biotin (H)
87
B9 Folsäure
Folic acid FOLAC (g)
Folate, food FOLFD (g)
Folate, DFE FOLDFE (g)
free folic acid
para Aminobenzosäure
94
95
B12 (Cobalamin)
Ino war heit
C (Ascorbinsäure)
99(Mineralstoffen)SpurenelementEisenZinkKupferMang anSelenium, Se SE (µg)FluoridjodSilizium


2
0




GCAL
ZF

ZE
ZK

KMD

ZB

ZW



MNA











sonst. organischen Säuren

ZA













Fluorid

























Vitamin B3 (Niacin)









Folate, total FOL










MineralMFEMZNMCUMMNMFMJ
Worksheet: Sheet1

[DocAElstein]

Existing code
Main sort routine

Sub ReorgBy3Criteria()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & DieseArbeitsmappe1.ProWb.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet: Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 VBA Range.Sort Method
' xlDescending Biggest at Top H Kcal J Fett L eiweiss
'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let rngToSort.Value2 = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub 'ReorgBy3Criteria
Coding Walkthrough Explanation
Rem 1 is not particularly relevant to the Sort process. This is just getting at the data worksheet containing the spreadsheet range to be sorted.
In this actual example a global variable, is held in the ThisWorkbook code module, ProWb, holding the data workbook as an object. This would usually be filled on opening of the File containing the sort routine. Just in case it may not be filled, a routine is called to fill it. ( For English Excel, the routine would be placed in the ThisWorkbook code module, and referencing this variable would be by ThisWorkbook. FillMeGlobsUpMate in place of the German equivalent in my pre pre alpha Excel 2019 version which has the objects module DieseArbeitsmappe1
Rem 2 concerns determination of the range to be sorted, which in this case is the selection made in the active Window. In the actual example there are many columns and the number is known. The rows can be variable. ( Typical row selections are made in a large table and just those rows are sorted based on a few of the column values )
The Selection is used to obtain the start ( Top ) row, from an available property
objwinToSort.Selection.Row
and the stop ( bottom ) row is , as is often the case in VBA things, not available as a property, but the rows count is , so the typical formula is used to get that of pseudo like Stop = Start + ( RowCount – 1 )
StRow + objwinToSort.Selection.Rows.Count - 1
The column numbers of the range are hardcoded
I prefer to obtain my Range from the Range property method like Range(“A23:ZZ89”), so in order to do this when I use the column numbers, I use a simple function, CL( )
An array is made , ArrrngOrig() , to use as a back up from which to restore the original unsorted range if required later

Rem 3 main sort
A typical example is used , showing the Range.Sort method to sort the range by 3 columns. As main sort this will be having Kcal values of the highest at the top. For similar Kcal values the sort will be by the Fat , again with the larges at the top. In case any rows have the same Kcal and Fat values, then a last sort for those rows is made by highest Natrium at the top. ( Natrium = Sodium , which is a Salt derivative )
'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending

Rem 4 Possible reset of original range order
I would tend to usually include such a coding section as this in any sorting routine. The user has the possibility to accept the sorted range or use the array, ArrrngOrig(), to restore the original range unsorted.

Required Function and routine
In normal code module

Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
'Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible
Do
' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26
' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ?
' 'OR
Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula
Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
' https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887

Required routine in ThisWorkbook code module
In this actual example a global variable, is held in the ThisWorkbook code module, ProWb, holding the data workbook as an object. This would usually be filled on opening of the File containing the sort routine. Just in case it may not be filled, a routine is called to fill it. ( For English Excel, the routine would be placed in the ThisWorkbook code module, and referencing this variable would be by ThisWorkbook. FillMeGlobsUpMate in place of the German equivalent in my pre pre alpha Excel 2019 version which has the objects module DieseArbeitsmappe1

'' DieseArbeitsmappe1
' In Lis Workbook code module
Option Explicit
Public ProWb As Workbook '
Public Sub FillMeGlobsUpMate()
For Each ProWb In Workbooks
If VBA.Left$(ProWb.Name, 18) = "ProAktuellex8600x2" Then
'Set ProWb = ProWb ' Don't need this - it is effectively left set at current Workbook in loop, because you exit for.
Set LisWbProWb = ProWb
Exit For ' This is important or else you will need to uncommment Set ProWb = ProWb
Else
' MsgBox Prompt:="You don't seem to have a Pro open, my luv, x" The error handling, PoGoStRory: will do this for me onn the attempt at ProWb.Name
End If
Next ProWb
End Sub






Data Workbook ( for sample range ):
"ProAktuellex8600x2.xlsx" https://app.box.com/s/sspcm7a4w3t99wzezruxep7e7j51khju

[DocAElstein]

In support of this excelfox post:
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11037&viewfull=1#post11037


' Calling code for the main Array sort routine
Sub CallArraySort()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3488 ' 3482 '454 '99
Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 Array sort routine alternative coding
'3a) argumants for Called routine
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To rngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs
Dim arrTS() As Variant: Let arrTS() = ArrrngOrig()
'3b) Do sort
Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ")
Let rngToSort.Value = arrTS()
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let rngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub
'


The main recursion routine Called by the above routine,
Sub SimpleArraySort6(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
, is here
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10994&viewfull=1#post10994
and in this File
"ProAktuellex8600x2Sort1.xlsm" https://app.box.com/s/d6isabudadt3swnryxiz7motspzeqa17

[DocAElstein]

test post for URL

[DocAElstein]

test post for url