Page 2 of 19 FirstFirst 123412 ... LastLast
Results 11 to 20 of 185

Thread: Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

  1. #11
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    After from last two posts after running code :
    Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4()



    Using Excel 2007 32 bit
    Row\Col
    C
    D
    E
    F
    G
    H
    I
    J
    K
    L
    1
    121
    TEAM LEADER
    21.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    2
    121
    TEAM LEADER
    22.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    3
    121
    TEAM LEADER
    23.Dec.16
    7:00
    15:00
    8:00
    8:00
    H
    4
    121
    TEAM LEADER
    24.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    5
    121
    TEAM LEADER
    25.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    6
    121
    TEAM LEADER
    26.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    7
    121
    TEAM LEADER
    27.Dec.16
    7:00
    17:00
    10:00
    9:00
    1:00
    N
    8
    121
    TEAM LEADER
    28.Dec.16
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    9
    29.Dec.16
    ABSENT N
    10
    30.Dec.16
    ABSENT
    11
    31.Dec.16
    ABSENT N
    12
    121
    TEAM LEADER
    1.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    13
    121
    TEAM LEADER
    2.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    14
    121
    TEAM LEADER
    3.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    15
    121
    TEAM LEADER
    4.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    16
    121
    TEAM LEADER
    5.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    17
    121
    TEAM LEADER
    6.Jan.17
    H
    18
    121
    TEAM LEADER
    7.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    19
    121
    TEAM LEADER
    8.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    20
    121
    TEAM LEADER
    9.Jan.17
    ABSENT N
    21
    121
    TEAM LEADER
    10.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    22
    121
    TEAM LEADER
    11.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    23
    121
    TEAM LEADER
    12.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    24
    121
    TEAM LEADER
    13.Jan.17
    7:00
    18:00
    11:00
    10:00
    H
    25
    121
    TEAM LEADER
    14.Jan.17
    7:30
    17:30
    10:00
    9:00
    1:00
    N
    26
    121
    TEAM LEADER
    15.Jan.17
    7:30
    17:30
    10:00
    9:00
    1:00
    N
    27
    121
    TEAM LEADER
    16.Jan.17
    7:30
    17:30
    10:00
    9:00
    1:00
    N
    28
    121
    TEAM LEADER
    17.Jan.17
    7:30
    17:30
    10:00
    9:00
    1:00
    N
    29
    121
    TEAM LEADER
    18.Jan.17
    7:00
    18:00
    11:00
    9:00
    2:00
    N
    30
    19.Jan.17
    ABSENT N
    31
    121
    TEAM LEADER
    20.Jan.17
    H
    32
    33
    34
    25
    Normal Overtime ----->
    39
    Holiday Overtime ----->
    18
    Worksheet: Aftert121


    Using Excel 2007 32 bit
    Row\Col
    B
    C
    D
    E
    F
    G
    H
    I
    J
    34
    TOTAL NO. OF DAYS -----> =30-COUNTIF(K1:K31,"ABSENT")
    Normal Overtime ----->
    =SUMIF(L1:L31,"N",J1:J31)*24
    Holiday Overtime ----->
    =SUMIF(L1:L31,"H",J1:J31)*24
    Worksheet: After121
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  2. #12
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    HTML After using Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4()

    After from running code (HTML) :
    Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4()



    Excel 2007 32 bit
    DEFGHIJKL
    1TEAM LEADER21.Dec.167:0018:0011:009:002:00N
    2TEAM LEADER22.Dec.167:0018:0011:009:002:00N
    3TEAM LEADER23.Dec.167:0015:008:008:00H
    4TEAM LEADER24.Dec.167:0018:0011:009:002:00N
    5TEAM LEADER25.Dec.167:0018:0011:009:002:00N
    6TEAM LEADER26.Dec.167:0018:0011:009:002:00N
    7TEAM LEADER27.Dec.167:0017:0010:009:001:00N
    8TEAM LEADER28.Dec.167:0018:0011:009:002:00N
    929.Dec.16ABSENTN
    1030.Dec.16ABSENT
    1131.Dec.16ABSENTN
    12TEAM LEADER1.Jan.177:0018:0011:009:002:00N
    13TEAM LEADER2.Jan.177:0018:0011:009:002:00N
    14TEAM LEADER3.Jan.177:0018:0011:009:002:00N
    15TEAM LEADER4.Jan.177:0018:0011:009:002:00N
    16TEAM LEADER5.Jan.177:0018:0011:009:002:00N
    17TEAM LEADER6.Jan.17H
    18TEAM LEADER7.Jan.177:0018:0011:009:002:00N
    19TEAM LEADER8.Jan.177:0018:0011:009:002:00N
    20TEAM LEADER9.Jan.17ABSENTN
    21TEAM LEADER10.Jan.177:0018:0011:009:002:00N
    22TEAM LEADER11.Jan.177:0018:0011:009:002:00N
    23TEAM LEADER12.Jan.177:0018:0011:009:002:00N
    24TEAM LEADER13.Jan.177:0018:0011:0010:00H
    25TEAM LEADER14.Jan.177:3017:3010:009:001:00N
    26TEAM LEADER15.Jan.177:3017:3010:009:001:00N
    27TEAM LEADER16.Jan.177:3017:3010:009:001:00N
    28TEAM LEADER17.Jan.177:3017:3010:009:001:00N
    29TEAM LEADER18.Jan.177:0018:0011:009:002:00N
    3019.Jan.17ABSENTN
    31TEAM LEADER20.Jan.17H

    After121



    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  3. #13
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Totals output for last post ( HTML )

    Excel 2007 32 bit
    BCDEFGHIJ
    34TOTAL NO. OF DAYS  ----->25Normal Overtime  ----->39Holiday Overtime  ----->18

    After121



    Worksheet Formulas
    CellFormula
    C34=30-COUNTIF(K1:K31,"ABSENT")
    G34=SUMIF(L1:L31,"N",J1:J31)*24
    J34=SUMIF(L1:L31,"H",J1:J31)*24

    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  4. #14
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Top Part of Code 4 for Nelson

    Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4()



    This is the first part of a single code.
    The second part shpuld be copied directly under the first part in the same code module

    For this Post
    ' http://www.excelfox.com/forum/showth...iday-overtime?

    Code:
    '10   '  Code 4 for Nelson  '  Post 27    http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10094#post10094
    Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorksheetsCode4()            'http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10078#post10078
    20   Rem 1) Workbooks Info.
    30   Dim Wb As Workbook               ' Dim: For Object variabls: Address location to a "pointer". That has all the actual memory locations (addresses) of the various property values , and it holds all the instructions what / how to change them , should that be wanted later. That helped explain what occurs when passing an Object to a Call ed Fucntion or Sub Routine By Val ue. In such an occurance, VBA actually  passes a copy of the pointer.  So that has the effect of when you change things like properties on the local variable , then the changes are reflected in changes in the original object. (The copy pointer instructs how to change those values, at the actual address held in that pointer). That would normally be the sort of thing you would expect from passing by Ref erence.  But as that copy pointer "dies" after the called routine ends, then any changes to the Addresses of the Object Properties in the local variable will not be reflected in the original pointer. So you cannot actually change the pointer.)
    40    Set Wb = ActiveWorkbook         ' Set: Fill or partially Fill: Setting to a Class will involve the use of an extra New at this code line. I will then have an Object referred to as an instance of a Class. At this point I include information on my Pointer Pigeon hole for a distinct distinguishable usage of an Object of the Class. For the case of something such as a Workbook this instancing has already been done, and in addition some values are filled in specific memory locations which are also held as part of the information in the Pigeon Hole Pointer. We will have a different Pointer for each instance. In most excel versions we already have a few instances of Worksheets. Such instances Objects can be further used., - For this a Dim to the class will be necessary, but the New must be omitted at Set. I can assign as many variables that I wish to the same existing instance
    50   Dim wsStear As Worksheet         ' Used for each Worksheet counting Tabs from left from 1 To Total
    60   Rem 2) varables for some totals ;)
    70   'Const TDays As Long = 30           'Total days just taken as 30 INITIALLY  ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in.  '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )
    80   Dim Dte As Date, DteNo As Long                                              ' I am hoping Dte will sort out getting a date in a format that I can use the Weekday function to see what week day it is and get that as a nuumber to check for..
    90   Rem 3) Loop through worksheets and give some Totals
    100  Dim Cnt As Long ' Loop Bound variable count for going through all worksheets
    110  '3a) main Loop start=====================================================
    120      For Cnt = 1 To Wb.Worksheets.Count                                      ' The Worksheets collection Object Property returns the number of worksheet items in the Workbook
    130       Set wsStear = Wb.Worksheets.Item(Cnt)                                  ' At each loop the variable is set to the current Worksheet counting from the Cnt'ths tab from left
    140      Dim lr As Long                                                          ' Used for last row number in column E  ( The number of “Entries” is taken as the filled dates in column E )
    150       Let lr = wsStear.Range("E" & Rows.Count & "").End(xlUp).Row            ' The Range Object ( cell ) that is the last cell in the column of interest (CHOOSE a column typically that will always have a last Entry in any Data) ,( Row Number given by .Count Property applied to ( any Worksheet would do, so leaving unqualified is OK here, ) Spreadsheet Range Rows Property)    has the Property .End ( argument "Looking back up" ) appled to it. This Returns a new Range ( cell ) object which is that of the first Range ( cell ) with something in it "looking back up" in the XL spreadsheet from that last Cell. Then the .Row Property is applied to return a long number equal to the Row number of that cell:     Rows.Count is the very last row number in your Worksheet. It is different for earlier versions of Excel.  The End(xlUp) is the same as pressing a Ctrl+UpArrow key combination. The final ".Row" returns the row where the cursor stops after moving up.
    160       'Let lr = 30 ' maybe nelson means thís ? "...For all Month no. of days we take as 30 only..." For all Months, the “TOTAL NO. OF DAYS” ( to be placed in cell C34 ) is not necessarily the number of days worked.
    170       Let lr = wsStear.Range("E33").End(xlUp).Row                            ' To allow text below row 33
    180  'TOTAL NO. OF DAYS                                                           The formula for calculating this is:
    190  '                                                                            _Assuming the employee is not Absent for any day, then the “TOTAL NO. OF DAYS” is always taken as 30
    200  '                                                                            _ If the employee has one or more normal days of absence, ( normal days with no total working hours ), then the formula for calculating “TOTAL NO. OF DAYS” is as follows:
    210  '                                                                            TOTAL NO. OF DAYS = 30 – ( Count of “ABSENT” )
    220      Dim FstDtaCel As Range: Set FstDtaCel = wsStear.Range("A1")             'Top Left data ' Worksheets Range(" ") Property used to return Range object of first cell in second row
    230  '3b) Data arrays from worksheet. We need columns E H I J      ....   Date ( Column E ) and Total hrs ( Column H ) are required to use in calculations
    240      Dim arrInNorm() As Variant, arrInOver() As Variant                      ' In the next lines the .Value2 or .Value "values" Property is applied a Range object which presents the Value or Value2 value or values in a single variable of appropriate type or a field of member Elements of varaint types.We are expecting the latter, so declare ( Dim ) a dynamic Array variable appropriately. It must be dynamic as its size will be defined at that assignment
    250       Let arrInNorm() = FstDtaCel.Offset(0, 8).Resize(lr, 1).Value2 ' I      ' Normal Hrs ( Column I ) are needed as they must be set to zero for Holy ?? Holidays ?? Friday ??
    260       Let arrInOver() = FstDtaCel.Offset(0, 9).Resize(lr, 1).Value2 ' J      ' Overtime ( Column J ) is needed as it will be changed and then used in calculations
    270      Dim arrTotHrs() As Variant ' ,' ## ' arrDteClr() As Variant
    280       Let arrTotHrs() = FstDtaCel.Offset(0, 7).Resize(lr, 1).Value '  H      ' ' One thing you pick up when learning VBA programming is that referring to cells from one to another via an offset is both fundamental and efficient. That makes sense as Excel is all about using the offsets mentioned above. So like if you use them you can “cut out the middle man”. ( The middle man here might be considered as, for example, in VBA, using extra variables for different Range objects: A fundamental thing to do with any cell ( or strictly speaking the Range object associated to a cell ) is the Range Item Property of any range Object, through which you can “get at” any other Range object. http://www.excelforum.com/showthread.php?t=1154829&page=13&p=4563838&highlight=#post4563838 ( It is often quicker than using a separate variable for each Range object – probably as all the variable does is hold the offset , so you might as well use the offset in the first place.. )
    290                                                                              ' Similarly Another thing you pick up along the way is that the cells ( or strictly speaking the Range objects associated with it ) can be organised into groups of cells which then are also called Range objects and are organised in their constituent parts exactly the same as for the single cell Range object. Once again this is all an indication of organising so that we get at information by sliding along a specific amount ( offset value). The Offset and Resize properties therefore return a new range object. I use the .Value 2 here as i seemed to get it for .Value anyway, not sure why yet, - so i thought be on the safe side , get it always and work somehow with that for now and convert as necerssary.   Also 1 breadth Arrays due to Alan Intercept theory are held in such a ways as to be very effient in usage of values within
    300  'Column L ( help column )                                                    Column L ( help column )
    310  '                                                                            Nelson has chosen the second code. It puts formulas in cells C34, G34, and J34.
    320  '                                                                            This requires “H” or “N” to indicate Holiday or Normal working day. This will be written by the code in column L
    330      Dim arrL() As String 'I know the size, but must make it dynamic as Dim declaration only takes numbers, and so I use ReDim method below wehich can also take variables or formulas
    340       ReDim arrL(1 To UBound(arrInNorm(), 1), 1 To 1) ' Any array first dimension ("row") will do
    350  '“ABSENT”                                                                    “ABSENT” ( to be written in some rows in Column K by the program )
    360  '                                                                            Count of “ABSENT” is the number of occurrences of ABSENT in column K in the final ( After ) Worksheet “ABSENT” is to be written in some rows of column K by the code under certain criteria.
    370  '                                                                            ( “ABSENT” is not necessarily the normal working days in which an employee is absent and / or has no total working hours. )
    380  '                                                                            “ABSENT” is to be written in column K by the code under the following criteria:
    390  '                                                                            _ For the rows of all normal days when the employee has no working hours, ( days when the employee is absent ), “ABSENT” is to be written in column K.
    400  '                                                                            _ In addition , should it occur that an employee is absent for both the days before and after a holiday, then for the ( Holiday ) row in between those two days, “ABSENT” is to be written in column K.
    410  '                                                                            ( No consideration of this ““ABSENT” criteria thereof” is made for the case of a Holiday at the first or last “Entries” )
    420      Dim arrAbscentK() As String 'K column to have ABSCENT in for person Absent on not Holiday or Holiday written in K cloumn as ABSENT
    430       ReDim arrAbscentK(1 To UBound(arrInNorm(), 1), 1 To 1)
    440       'Must Loop to get interior color as this will not work.     ' ## ' Let arrDteClr() = FstDtaCel.Offset(0, 4).Resize(lr, 1).Interior.Color  '  because .Interior property for a Range object shows only one value for the entire range which seems to be zero unless all the cells have a colour
    Last edited by DocAElstein; 02-09-2017 at 05:11 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  5. #15
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4() Part 2

    For Post http://www.excelfox.com/forum/showth...0094#post10094

    This is the second part os a single code.
    This second part shpuld be copied directly under the first part in the same code module




    Code:
    '440       'Must Loop to get interior color as this will not work.     ' ## ' Let arrDteClr() = FstDtaCel.Offset(0, 4).Resize(lr, 1).Interior.Color  '  because .Interior property for a Range object shows only one value for the entire range which seems to be zero unless all the cells have a colour
    450      Dim arrDteClr() As Double, rngDts As Range
    460       Set rngDts = FstDtaCel.Offset(0, 4).Resize(lr, 1)
    470      Dim Rws As Long: ReDim arrDteClr(1 To lr, 1 To 1) ' so must loop in each Interior color value
    480          For Rws = 1 To UBound(arrDteClr(), 1) Step 1 'InnerLoop for dates background colors
    490           Let arrDteClr(Rws, 1) = rngDts.Item(Rws, "A").Interior.Color
    500          Next Rws
    510  '3c) Inner loop for rows
    520      Dim ShtCnt As Long ' Loop Bound Variable Count for hours columns looping
    530      Dim ValidHoliday As Boolean: Let ValidHoliday = True 'Assume for now Holiday days are valid for Holiday adjustments
    540          For ShtCnt = 1 To UBound(arrDteClr(), 1) Step 1 '------------------- For "rows" in data arrays
    550  '3d) We need to check Interior color, and a few other things,    Adjust columns I and J so that column I has no hours for holiday day and total hours goes to over time hours with criteria 9 or less than 9 hrs all total hours added overtime, 10 or above 10 hrs one hour deducted from total hours and added to column J   ..... and add a H or N in helper column K
    560              If arrDteClr(ShtCnt, 1) = 65535 Then                                ' We have a Holiday, ...but... have some other checks
    570                  If Not (ShtCnt = 1 Or ShtCnt = UBound(arrDteClr(), 1)) Then       ' ....but... Possible futher checks for not adjusting Normal Total Hrs to overtime and remove normal Hrs
    580                  'It is possible to check for absent before and after current day
    590                      If arrTotHrs(ShtCnt - 1, 1) = Empty And arrTotHrs(ShtCnt + 1, 1) = Empty Then '...."...holiday is deducted if the person does not come the day before and after the holiday...".... To facilitate this "ABSENT" is written in column K so that 30 - CountIf ABSENT will "remove a Holiday pay"
    600                       Let ValidHoliday = False
    610                      Else
    620                       Let ValidHoliday = True
    630                      End If
    640                  Else 'It is not possible for absence before AND after to check for absence as one will lie in last or next month
    650                  End If ' We remmain at default  or last set true or just set true or false
    660                  'We had Holiday ...
    670                  If ValidHoliday = True Then ' ...and all conditions for valid Holiday pay adjustments
    680                  'Conditions met to adjust make all of 1 less of Normal Hrs to overtime
    690                     If (arrTotHrs(ShtCnt, 1) * 24) <= 9 Then                    '(i) If  Total Hrs are less than or equal to 9 ,Then all  Total Hrs are added to Overtime Hrs
    700                      Let arrInOver(ShtCnt, 1) = arrTotHrs(ShtCnt, 1)            ' Given To ' Added to arrInOver(ShtCnt, 1) + arrTotHrs(ShtCnt, 1)
    710                     ElseIf (arrTotHrs(ShtCnt, 1) * 24) > 9 Then                 ' (ii) If  Total Hrs are less greater than 9 , Then (  Total Hrs - 1 )  are added to Overtime Hrs
    720                      Let arrInOver(ShtCnt, 1) = arrTotHrs(ShtCnt, 1) - 1 / 24   ' Given To      ' arrInOver(ShtCnt, 1) + arrTotHrs(ShtCnt, 1) - 1 / 24 'Added to  1 hr less overtime for more than 9 hrs worked
    730                     End If
    740                   Let arrInNorm(ShtCnt, 1) = Empty                               ' (iii) As array is variant type can empty     Remove normal Hrs  Array for(Column I) is then set tom zerow for this "row"
    750                   Let arrL(ShtCnt, 1) = "H" '                                    ' (iv)H '_-Give string, "" value of H for valid Holiday in Admin's help column
    760                  Else ' We had a  Holiday but abscence before and after, we make in this case the AbsentK column ABSENT
    770                   Let arrAbscentK(ShtCnt, 1) = "ABSENT"                                                                      '_- This is unusual "Abscent" case. If after and before the Holiday, the employee is absent, then the Holiday is "marked" ( in column K ) as ABSENT. This
    780                   Let ValidHoliday = True 'we need to reset to true
    790                  End If
    800              Else ' No Holy Holiday
    810               Let arrL(ShtCnt, 1) = "N" ' give string N for normal               ' (iv)N '_-Give string, "" value of N for normal Day
    820              End If
    830              If arrTotHrs(ShtCnt, 1) = Empty And Not arrDteClr(ShtCnt, 1) = 65535 Then Let arrAbscentK(ShtCnt, 1) = "ABSENT" '_- column K absent days should be marked as ABSENT. This is normal Absent case for normal workdays when employee is abscent
    840  '3e) ' from last code,  is not now used to calculate totals
    850          Next ShtCnt '--------------------------End Inner loop for rows-----
    860  '3f) Paste out final Totals and days to current Worksheet
    870       Let wsStear.Range("G34").Value = "=SUMIF(L1:L" & lr & ",""N"",J1:J" & lr & ")*24"
    880       Let wsStear.Range("J34").Value = "=SUMIF(L1:L" & lr & ",""H"",J1:J" & lr & ")*24"
    890       Let wsStear.Range("C34").Value = "=30-COUNTIF(K1:K" & lr & ",""ABSENT"")"
    900  '3g) Normal   Hrs  ( Column I ) and Overtime Hrs ( Column J ) are  changed ' And can paste out help column if you like
    910       Let FstDtaCel.Offset(0, 9).Resize(lr, 1).Value2 = arrInOver()    ' J       ' The required spreadsheet cells range has its Range Object .Value2 values filled an allowed direct assignment to an array of values
    920       Let FstDtaCel.Offset(0, 8).Resize(lr, 1).Value2 = arrInNorm()    ' I
    930       Let FstDtaCel.Offset(0, 11).Resize(lr, 1).Value2 = arrL()        ' L
    940       Let FstDtaCel.Offset(0, 10).Resize(lr, 1).Value2 = arrAbscentK() ' K
    950  '3h) Set Booleans for
    960      Next Cnt '==End main Loop==============================================
    End Sub
    '970  '
    '980  'Rem Ref:   http://www.excelfox.com/forum/showthread.php/2138-Understanding-VBA-Range-Object-Properties-and-referring-to-ranges-and-spreadsheet-cells
    '990  '
    '1000
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  6. #16
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    All Sub Folder and File List from VBA Recursion routine. Explanation and Method Comparisons

    Codes required for contribution to , and to be referenced from, these Threads: http://www.excelfox.com/forum/showth...lder-Using-VBA
    https://excel.tips.net/T008233_Findi...e_Desktop.html
    http://www.excelfox.com/forum/showth...ll=1#post12095

    Theses are

    _ the main initial code , ( Sub ( ) ) , used in a two code solution "recursion type" solution for Looping through all Folders and Subfolders and Files , starting from an in initial Folder which is given in this code and passed to the second code,

    _ a "recursion type" code. This code successively takes a Folder, looks into its subfolders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders,…. Etc…..

    The codes are discussed in detail at that Thread , starting from this post:



    Initial Code to call the recursion code given below

    Code:
    '====================================
    ' Dec 2017 For Python Comparison.                                                                                                    Tutorial Post: excelforum:         Tutorial Post: ExcelFox:
    'http://excelpoweruser.blogspot.de/2012/04/looping-through-folders-and-files-in.html     http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html#post4316662    http://www.excelfox.com/forum/f5/loop-through-files-in-a-folder-using-vba-1324/
    Sub VBADoStuffInFoldersInFolderRecursion() 'Main routine to "Call" the first copy of the second routine,  VBALoopThroughEachFolderAndItsFile(
    Rem 1A) Some Worksheets and General Variables Info
    Dim Ws As Worksheet           '_-Dim: Prepares "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular "Value", or ("Values" for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post4411
     Set Ws = ThisWorkbook.Worksheets.Item(1) 'Worksheets("EFFldr") 'CHANGE TO SUIT YOUR WORKSHEET    '_- Set: Fill or partially Fill: Setting to a Class will involve the use of an extra New at this code line. I will then have an Object referred to as an instance of a Class. At this point I include information on my Pointer Pigeon hole for a distinct distinguishable usage of an Object of the Class. For the case of something such as a Workbook this instancing has already been done, and in addition some values are filled in specific memory locations which are also held as part of the information in the Pigeon Hole Pointer. We will have a different Pointer for each instance. In most excel versions we already have a few instances of Worksheets. Such instances Objects can be further used., - For this a Dim to the class will be necessary, but the New must be omitted at Set. I can assign as many variables that I wish to the same existing instance
     Ws.Range("B3:F30").ClearContents ' This line only needed for demo code
    Dim celTL As Range: Set celTL = Ws.Range("B3") 'Top left of where Listing should go
    Rem 2A) Get Folder Info
    Dim strWB As String ' "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular "Value", or ("Values" for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
     Let strWB = ThisWorkbook.Path & "\" & "EileensFldr" ' 'CHANGE TO SUIT if you store the main Folder to be looked through somewhere other than in the same Folder as this workbook in which the codes are in
    Rem 3A ) ' FileSystemObject Object
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject") 'Late Binding
    'Dim FSO As Scripting.FileSystemObject 'Early Binding alternative  activate a reference to the Microsoft Scripting Runtime Library ( MSRL ) in the Tools References menu of VB Editor Options.
    'Set FSO = New Scripting.FileSystemObject 'Create an Instance of the Class Scripting FileSystemObject
    Dim myFolder As Object 'An Object from myFolder, can be an declared as Dim myFolder As Folder also for Early Binding
    Set myFolder = FSO.GetFolder(strWB) 'Set the selected Folder to the Object Folder using this Method which takes as arbument the Full String Path
    Rem 4A )
    Dim rCnt As Long: Let rCnt = 1: Dim CopyNumber1 As Long: Let CopyNumber1 = 1 '"Run progressin ( "down vertical" ) axis ( Row count for output ), "Down Folder chain to the right", The Count of the Copy of the called Procedue, here set to 1 for the first called copy of the second routine, which is done from this Sub( )  . Any subsequent calls of further second routine copies will be made by the current copy as it "freezes" and sets of that next copy
    celTL.Value = myFolder.Path: celTL.Offset(0, 1).Value = myFolder.Name: Ws.Columns("A:C").AutoFit 'First output Row
    '( -- Rem 5A) )
    Call LoopThroughEachFolderAndItsFile(myFolder, celTL, rCnt, CopyNumber1) 'Up until now we just got the initial Folder. Now we go to all sub folders  then all subfolders   then all subfolders.......
    ' let Application.ScreenUpdating = True ' If this had been set to False earlier towards the start, as is often done, then the code might run a bit quicker by virtue of not updating the worksheet everytime an entry is made, but it is not really nacerssary unless the number of Files and Folders is massive. Even then it is probably better not to do that so that in the case of an error one has an additional way in the worksheet to see where the code stopped / errored
    MsgBox "All Excel Files processed", vbInformation
    Ws.Columns("A:H").AutoFit
    End Sub
    'Rem 5A) --

    _........

    _._________________

    Second code. Recursion routine

    Code:
    'Rem 5A) --
    Sub VBALoopThroughEachFolderAndItsFile(ByVal fldFldr As Object, ByRef celTL As Range, ByRef rCnt As Long, ByVal CopyNumberFroNxtLvl As Long)  'In below function we have a nested loop to iterate each files also
    Dim myFldrs As Object ''This is used continuously as the "steering" thing, that is to say each Sub Folder in Folder loops, in loops, in loops......etc   ....can be Dim myFldrs As Folder for early bindingDim CopyNumber As Long 'equivalent to clmLvl in Rudis Q code
    Dim CopyNumber As Long 'equivalent to clmLvl in Rudis Q code
     Let CopyNumber = CopyNumberFroNxtLvl 'This variable is local to the current running or paused copy of this routine.
        '5Ab) Doing stuff for current Folder
        For Each myFldrs In fldFldr.SubFolders 'SubFolders collection used to get at all Sub Folders
        ''''''''Doing stuff for each Folder, .. in this example giving '_-
                '_- its full path including name :                 and just Flder Name                             ' -- *
         Let rCnt = rCnt + 1 + 1 ''At each folder we always move down a line, and a dd amm extra line  as a space between Folders ( The indication of the "column" or "down" to the right comes from the Copy Number of the Sub Procedure
         Let celTL.Cells(rCnt, 1).Value = myFldrs.Path: celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = myFldrs.Name ' -- *                                            'Print out current Folder Path and Name in next free row.
        ''''''''End doing stuff for each Folder
        '5Ac) Doing stuff for current file.
        Dim oFile As Object '  ... for early binding can Dim oFile As file
                For Each oFile In myFldrs.Files 'Looking at all Files types initially '#####
                ''''''''Doing Stuff for Each File
        '            Dim Extension As String: Let Extension = Right(oFile.Name, (Len(oFile.Name) - (InStrRev(oFile.Name, ".")))) 'To get the bit just after the . dot.  #####
        '                If Left(Extension, 3) = "xls" Then 'Check for your required File Type    #####
                    Let rCnt = rCnt + 1
                    celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = oFile.Name ' Do your stuff here
        '                Dim wkb As Workbook
                         On Error GoTo ErrHdlr 'In case problem opening file for example
        '                Set wkb = Workbooks.Open(oFile)
        '                wkb.Close SaveChanges:=True
        '                Else 'Do not do stuff for a Bad Extension                        ' #####
        '                End If '                                                         #####
                ''''''''End Doing Sttuff for Each File
    NxtoFile:   Next oFile ' Spring Point after error handler so as to go on to next File after the File action that errored
        Call LoopThroughEachFolderAndItsFile(myFldrs, celTL, rCnt, CopyNumber + 1) 'This is an example of recursion. It is actually very simple once you understand it. But it is just incredibly difficult to put in words. It is basically a Procedure that keeps calling itself as much as necessary as it goes "along",  "down", or "to the right" of the Path "roots". Every time it goes off calling itself VBA runs a copy of that Procedure. It "Stacks" all info carefully for each "Copy" Run and continues to do this "drilling" down as far as it must, in this case finding the Next Folder, and then the next Folder in that, then the next Folder in that, then the next Folder in that...I think you get the point! Each time VBA makes a copy of the Routine and you go into that. The calling Routine then "freezes at its current state and all variable keep there values. The "Frozen" Routine then re starts when the copy finishes
        Next
    Exit Sub 'Normal End for no Errors
    Rem 6 ) Error handler section just put here for convenience
    ErrHdlr: 'Hopefully we know why we are here, and after informing can continue ( to next file )
    MsgBox prompt:="Error " & Err.Description & " with File " & oFile & ""
    On Error GoTo -1 'This needs to be done to reset the VBA exceptional error state of being. Otherwise VBA "thinks" Errors are being handeled and will not respond again to the Error handler.
    On Error GoTo 0 ' Swiches off the current error handler. I do not really need to do this. But it is good practice so the error handler is only in place at the point where i next am expecting an error
    GoTo NxtoFile
    End Sub
    _..

    ( Codes are also in the first Worksheet Code module of this Workbook: ( '== ' Dec 2017 For Python Comparison. https://app.box.com/s/gfuintgifu1hgw5nap3jriz2x8mp911x ) )
    Last edited by DocAElstein; 01-23-2020 at 03:49 PM.

  7. #17
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Dumping Logs. Recurring Excample

    Dumping Logs for support of this Thread Post:
    http://www.excelfox.com/forum/showth...0476#post10476

    Test Function used to produce the Log below

    Code:
    'Going a HoldYaBackCalledYaBackClapTrapRuc - Copy number_GlobinalCntChopsLog - a few copies of this are made and run. (Recursion)
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 5+30=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Private Function HoldYaBackCalledYaBackClapTrapRuc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long   '                                   ByVal CopyNumberFroNxtLvl As Long) As Long
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog + 1: Debug.Print " Going a HoldYaBackCalledYaBackClapTrapRuc"; GlobinalCntChopsLog; "(1Msg"; lMsg; ", wParam"; wParam; ", lParam"; lParam; ") Function Copy Number_"; GlobinalCntChopsLog
                                'If GlobinalCntChopsLog = 2 Then Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1: UnHookWindowsHookCodEx hHookTrapCrapNumber: Exit Function
        If lMsg = 5 Then '_-.... ( Hook type: HCBT_ACTIVATE = 5 but not here?) ... this runs a further 29 copies of HoldYaBackCalledYaBackClapTrap all coming here, so 30 times in total
                                Debug.Print "Expose Interface"; Tab(30); GlobinalCntChopsLog
         SetWindowPosition wParam, 0, poX, pussY, 400, 150, 40 '             SWP_NOZORDER is 4 ..  but not here?? 'SWP_NOSIZE + SWP_NOZORDER ' Pull the Chainge position ...
         UnHookWindowsHookCodEx hHookTrapCrapNumber         ' Release the Hook 30 times this is done
        Else
                                Debug.Print "No InterOfCourse"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        End If ' 5 times here then '_-....
                                Debug.Print "Wipe chain WRap"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        Let HoldYaBackCalledYaBackClapTrapRuc = 0 '  Done  5+30=35 times in total  '0 (or False) makes it work, all other numbers and I get no Message box
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1
    End Function ' HoldYaBackCalledYaBackClapTrapRuc


    Code:
    ---------------------------
    MutsNuts AkaApi working ApplicationPromptToRangeInputBox
    ---------------------------
    Select Range
    ---------------------------
    OK   
    ---------------------------
    
    WndNumber 66770    HandleWndOfMyParent 983700    hWndDskTop 66204    hHookTrapCrapNumber
    State of Much Such Penialtration's Number   HookCodeXcretion's
    ================== AliAs Pull of my chain   AliAs my long Hook
                                                                               0 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 2623104 , lParam 2353392 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 1377832 , lParam 2353500 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 3934358 , lParam 2353500 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 984706 , lParam 2353480 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 9 , wParam 3934358 , lParam 66766 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 5 , wParam 2623104 , lParam 2353812 ) Function Copy Number_ 1 
    Expose Interface              1 
     Going a HoldYaBackCalledYaBackClapTrapRuc 2 (1Msg 5 , wParam 2623104 , lParam 2353500 ) Function Copy Number_ 2 
    Expose Interface              2 
     Going a HoldYaBackCalledYaBackClapTrapRuc 3 (1Msg 5 , wParam 2623104 , lParam 2353188 ) Function Copy Number_ 3 
    Expose Interface              3 
     Going a HoldYaBackCalledYaBackClapTrapRuc 4 (1Msg 5 , wParam 2623104 , lParam 2352876 ) Function Copy Number_ 4 
    Expose Interface              4 
     Going a HoldYaBackCalledYaBackClapTrapRuc 5 (1Msg 5 , wParam 2623104 , lParam 2352564 ) Function Copy Number_ 5 
    Expose Interface              5 
     Going a HoldYaBackCalledYaBackClapTrapRuc 6 (1Msg 5 , wParam 2623104 , lParam 2352252 ) Function Copy Number_ 6 
    Expose Interface              6 
     Going a HoldYaBackCalledYaBackClapTrapRuc 7 (1Msg 5 , wParam 2623104 , lParam 2351940 ) Function Copy Number_ 7 
    Expose Interface              7 
     Going a HoldYaBackCalledYaBackClapTrapRuc 8 (1Msg 5 , wParam 2623104 , lParam 2351628 ) Function Copy Number_ 8 
    Expose Interface              8 
     Going a HoldYaBackCalledYaBackClapTrapRuc 9 (1Msg 5 , wParam 2623104 , lParam 2351316 ) Function Copy Number_ 9 
    Expose Interface              9 
     Going a HoldYaBackCalledYaBackClapTrapRuc 10 (1Msg 5 , wParam 2623104 , lParam 2351004 ) Function Copy Number_ 10 
    Expose Interface              10 
     Going a HoldYaBackCalledYaBackClapTrapRuc 11 (1Msg 5 , wParam 2623104 , lParam 2350692 ) Function Copy Number_ 11 
    Expose Interface              11 
     Going a HoldYaBackCalledYaBackClapTrapRuc 12 (1Msg 5 , wParam 2623104 , lParam 2350380 ) Function Copy Number_ 12 
    Expose Interface              12 
     Going a HoldYaBackCalledYaBackClapTrapRuc 13 (1Msg 5 , wParam 2623104 , lParam 2350068 ) Function Copy Number_ 13 
    Expose Interface              13 
     Going a HoldYaBackCalledYaBackClapTrapRuc 14 (1Msg 5 , wParam 2623104 , lParam 2349756 ) Function Copy Number_ 14 
    Expose Interface              14 
     Going a HoldYaBackCalledYaBackClapTrapRuc 15 (1Msg 5 , wParam 2623104 , lParam 2349444 ) Function Copy Number_ 15 
    Expose Interface              15 
     Going a HoldYaBackCalledYaBackClapTrapRuc 16 (1Msg 5 , wParam 2623104 , lParam 2349132 ) Function Copy Number_ 16 
    Expose Interface              16 
     Going a HoldYaBackCalledYaBackClapTrapRuc 17 (1Msg 5 , wParam 2623104 , lParam 2348820 ) Function Copy Number_ 17 
    Expose Interface              17 
     Going a HoldYaBackCalledYaBackClapTrapRuc 18 (1Msg 5 , wParam 2623104 , lParam 2348508 ) Function Copy Number_ 18 
    Expose Interface              18 
     Going a HoldYaBackCalledYaBackClapTrapRuc 19 (1Msg 5 , wParam 2623104 , lParam 2348196 ) Function Copy Number_ 19 
    Expose Interface              19 
     Going a HoldYaBackCalledYaBackClapTrapRuc 20 (1Msg 5 , wParam 2623104 , lParam 2347884 ) Function Copy Number_ 20 
    Expose Interface              20 
     Going a HoldYaBackCalledYaBackClapTrapRuc 21 (1Msg 5 , wParam 2623104 , lParam 2347572 ) Function Copy Number_ 21 
    Expose Interface              21 
     Going a HoldYaBackCalledYaBackClapTrapRuc 22 (1Msg 5 , wParam 2623104 , lParam 2347260 ) Function Copy Number_ 22 
    Expose Interface              22 
     Going a HoldYaBackCalledYaBackClapTrapRuc 23 (1Msg 5 , wParam 2623104 , lParam 2346948 ) Function Copy Number_ 23 
    Expose Interface              23 
     Going a HoldYaBackCalledYaBackClapTrapRuc 24 (1Msg 5 , wParam 2623104 , lParam 2346636 ) Function Copy Number_ 24 
    Expose Interface              24 
     Going a HoldYaBackCalledYaBackClapTrapRuc 25 (1Msg 5 , wParam 2623104 , lParam 2346324 ) Function Copy Number_ 25 
    Expose Interface              25 
     Going a HoldYaBackCalledYaBackClapTrapRuc 26 (1Msg 5 , wParam 2623104 , lParam 2346012 ) Function Copy Number_ 26 
    Expose Interface              26 
     Going a HoldYaBackCalledYaBackClapTrapRuc 27 (1Msg 5 , wParam 2623104 , lParam 2345700 ) Function Copy Number_ 27 
    Expose Interface              27 
     Going a HoldYaBackCalledYaBackClapTrapRuc 28 (1Msg 5 , wParam 2623104 , lParam 2345388 ) Function Copy Number_ 28 
    Expose Interface              28 
     Going a HoldYaBackCalledYaBackClapTrapRuc 29 (1Msg 5 , wParam 2623104 , lParam 2345076 ) Function Copy Number_ 29 
    Expose Interface              29 
     Going a HoldYaBackCalledYaBackClapTrapRuc 30 (1Msg 5 , wParam 2623104 , lParam 2344764 ) Function Copy Number_ 30 
    Expose Interface              30 
    Wipe chain WRap               30                  276039693 
    Wipe chain WRap               29                  276039693 
    Wipe chain WRap               28                  276039693 
    Wipe chain WRap               27                  276039693 
    Wipe chain WRap               26                  276039693 
    Wipe chain WRap               25                  276039693 
    Wipe chain WRap               24                  276039693 
    Wipe chain WRap               23                  276039693 
    Wipe chain WRap               22                  276039693 
    Wipe chain WRap               21                  276039693 
    Wipe chain WRap               20                  276039693 
    Wipe chain WRap               19                  276039693 
    Wipe chain WRap               18                  276039693 
    Wipe chain WRap               17                  276039693 
    Wipe chain WRap               16                  276039693 
    Wipe chain WRap               15                  276039693 
    Wipe chain WRap               14                  276039693 
    Wipe chain WRap               13                  276039693 
    Wipe chain WRap               12                  276039693 
    Wipe chain WRap               11                  276039693 
    Wipe chain WRap               10                  276039693 
    Wipe chain WRap               9                   276039693 
    Wipe chain WRap               8                   276039693 
    Wipe chain WRap               7                   276039693 
    Wipe chain WRap               6                   276039693 
    Wipe chain WRap               5                   276039693 
    Wipe chain WRap               4                   276039693 
    Wipe chain WRap               3                   276039693 
    Wipe chain WRap               2                   276039693 
    Wipe chain WRap               1                   276039693
    _-.__________________________________

    Windows Handleing Info:
    Code:
    ' 1b)        To hang in the Excel Window malking it effectively a Excel Msgbox... Normally if I did not do this  ... don't do this .. that is to say leave it at 0 , specifically no window is 0 , and it "hanging in mid air so isn't even if it is   imaginatively speaking
    Public Declare Function FindWndNumber Lib "user32" Alias "FindWindowA" (Optional ByVal lpClassName As String, Optional ByVal lpWindowName As String) As Long
    Dim HandleWndOfMyParent As Long      ' I wanted to comment  this  1b)(i) and ( 1b(ii) later )   out to leave it hanging in mid air in a virtual  inadvirtual not thereness  ... but somehow this complicated hook stuff does hang it somwhere but not in my Excel Window                                                                                                            but I don't know what my parent's fart has to do with anything
    ' 1d)        For some Misc experiments
    Private Declare Function FindWindowExtremeNutty Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Dim WndNumber As Long, hWndDskTop As Long
    Code:
    Sub AkaApiApplicationPromptToRangeInputBox()  ' This one works.. but HTF
            ' 1b(ii)  This section is some how over written in / by the section part or some strange Addressing of HoldYaBackCalledYaBackClapTrap
             Let WndNumber = FindWndNumber(lpClassName:=vbNullString, lpWindowName:=vbNullString)
             Let HandleWndOfMyParent = FindWndNumber(lpClassName:="XLMAIN", lpWindowName:=vbNullString) ' This is a case where vbNullstring is important - that signifies that I am not giving it, which i do not have to. The second option is a bit flaky and does not often work. it certainly won't work if you make it "" as that is a specific string of zero.  Null  is a special idea in computing of not set yet / not defined - that is required if I do not want to give it
            ' 1d) Just some experiments, I forgot why as my brain has goine comfortably numb
             Dim HeavyWindBreak As Long: Let HeavyWindBreak = HandleWndOfMyParent
             Let hWndDskTop = FindWindowExtremeNutty(HandleWndOfMyParent, 0&, "XLDESK", vbNullString)
                                Debug.Print "WndNumber"; WndNumber; "   HandleWndOfMyParent"; HandleWndOfMyParent; "   hWndDskTop"; hWndDskTop; "   hHookTrapCrapNumber"
    Rem 3                                   Mess with me hook? God knows what this all does and it seems to make no difference if the proXYs poX or pussY are before or after SetWindowsHooksExample
    Last edited by DocAElstein; 02-07-2018 at 07:31 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  8. #18
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Per PM request: One full working example of above code:

    Code:
    Option Explicit
    Rem 1 ' This I understand. it is a simple more basic version of the VBA Message Box Function                                       http://www.eileenslounge.com/viewtopic.php?f=18&t=28885#p223629
    ' 1a)          UnWRap it and..
    Private Declare Function APIssinUserDLL_MsgBox Lib "user32" Alias "MessageBoxA" (Optional ByVal HowManyFartsCanYouHandle As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal buttons As Long) As Long '
    ' 1b)        To hang in the Excel Window malking it effectively a Excel Msgbox... Normally if I did not do this  ... don't do this .. that is to say leave it at 0 , specifically no window is 0 , and it "hanging in mid air so isn't even if it is   imaginatively speaking
    Public Declare Function FindWndNumber Lib "user32" Alias "FindWindowA" (Optional ByVal lpClassName As String, Optional ByVal lpWindowName As String) As Long
    Dim HandleWndOfMyParent As Long      ' I wanted to comment  this  1b)(i) and ( 1b(ii) later )   out to leave it hanging in mid air in a virtual  inadvirtual not thereness  ... but somehow this complicated hook stuff does hang it somwhere but not in my Excel Window                                                                                                            but I don't know what my parent's fart has to do with anything
    ' 1d)        For some Misc experiments
    Private Declare Function FindWindowExtremeNutty Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Dim WndNumber As Long, hWndDskTop As Long
    Dim Booloks As Boolean
    '_-_._______________________________________________-
    '_-=================??? main Declarations that I don't really understand
    Rem 2 Position my box --- From here on I do not really have a clue
    ' 2(a)                                        This will tie something on the chain for when you pull it                                                                                                      https://msdn.microsoft.com/en-us/library/windows/desktop/ms644990(v=vs.85).aspx
    Private Declare Function SetWindowsHooksExample Lib "user32" Alias "SetWindowsHookExA" (ByVal Hooktype As Long, ByVal lokprocedureAddress As Long, Optional ByVal hmod As Long, Optional ByVal dwThreadId As Long) As Long
    ' 2(b)                                        Wipe the chain clean
    Private Declare Function UnHookWindowsHookCodEx Lib "user32" Alias "UnhookWindowsHookEx" (ByVal hHookTrapCrapNumber As Long) As Long
    ' 2(c)                                        Don't loose the Thread? - This seems to have no effect , - maybe it would if something else was going on at the time. You don't want to loose the Thread I guess
    'Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long ' Effectively long Null acttuall not ?? -
    Public Declare Function GetCurrentFredId Lib "kernel32" Alias "GetCurrentThreadId" () As Long ' Effectively long Null acttuall not ?? -
    ' 2(d)                                        This looks understandable almost, z(0 for top), posLeft, posTop, x pixels, y pixels,
    Private Declare Function SetWindowPosition Lib "user32" Alias "SetWindowPos" (ByVal hWnd As Long, ByVal zNumber As Long, ByVal CoedX As Long, ByVal CoedY As Long, ByVal xPiXel As Long, ByVal yPiYel As Long, ByVal wFlags As Long) As Long
    ' 2e)
    Private hHookTrapCrapNumber As Long                         ' Handle to the Hook procedure
    ' 2f)
    Private poX As Long: Private pussY As Long    ' Positional By proXYs
                                Dim GlobinalCntChopsLog As Long   ' Only used in this test code to keep track of the copies of a Function(HoldYaBackCalledYaBackClapTrap) used in a recursion process
    ' 2g) bits to do with 1 that i am resonably happy with
    Sub AkaApiApplicationPromptToRangeInputBox()  ' This one works.. but HTF
            ' 1b(ii)  This section is some how over written in / by the section part or some strange Addressing of HoldYaBackCalledYaBackClapTrap
             Let WndNumber = FindWndNumber(lpClassName:=vbNullString, lpWindowName:=vbNullString)
             Let HandleWndOfMyParent = FindWndNumber(lpClassName:="XLMAIN", lpWindowName:=vbNullString) ' This is a case where vbNullstring is important - that signifies that I am not giving it, which i do not have to. The second option is a bit flaky and does not often work. it certainly won't work if you make it "" as that is a specific string of zero.  Null  is a special idea in computing of not set yet / not defined - that is required if I do not want to give it
            ' 1d) Just some experiments, I forgot why as my brain has goine comfortably numb
             Dim HeavyWindBreak As Long: Let HeavyWindBreak = HandleWndOfMyParent
             Let hWndDskTop = FindWindowExtremeNutty(HandleWndOfMyParent, 0&, "XLDESK", vbNullString)
                                Debug.Print "WndNumber"; WndNumber; "   HandleWndOfMyParent"; HandleWndOfMyParent; "   hWndDskTop"; hWndDskTop; "   hHookTrapCrapNumber"
    Rem 3                                   Mess with me hook? God knows what this all does and it seems to make no difference if the proXYs poX or pussY are before or after SetWindowsHooksExample
                                Debug.Print "State of Much Such"; Tab(20); "Penialtration's Number"; Tab(45); "HookCodeXcretion's"
                                Debug.Print "=================="; Tab(20); "AliAs Pull of my chain"; Tab(45); "AliAs my long Hook"
                                Let GlobinalCntChopsLog = 0:
    '_-======================== Weird thing with an AddressOf ???
    Let poX = 10: pussY = 50 ' These can go before or after the next line, makes no diffference.. -                                                    I bet no Pro noticed that...
    'Let hHookTrapCrapNumber = SetWindowsHooksExample(5, AddressOf HoldYaBackCalledYaBackClapTrap, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
                                Debug.Print ; Tab(75); hHookTrapCrapNumber '                                                                                           'APIssinUserDLL_MsgBox HeavyWindBreak, "Excel MsgBox", "This is Center Position", vbOKOnly ' This breaks Wnd in Excel Window
     Call HookAPIssinUserDLL_MsgBoxThenDropIt
     'APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
     'APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
     'HookAPIssinUserDLL_MsgBoxThenDropIt
                                                                                                              
                                                                                                              Dim Rng As Range: Set Rng = Selection
    ' (Optional ByVal hwnd As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal buttons As Long) As Long '
    End Sub ' AkaApiApplicationPromptToRangeInputBox
    Sub HookAPIssinUserDLL_MsgBoxThenDropIt()
    Code:
    Sub HookAPIssinUserDLL_MsgBoxThenDropIt()
    ' a) HOOK Hook the pseudo Windows Sub Class Function WinSubWinCls_JerkBackOffHooKerd
    Dim BookMarkClassTeachMeWind As Long: Let BookMarkClassTeachMeWind = 5
     'Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTraped, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
     'Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTrapRuc, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
     Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTrapRuc, 0, GetCurrentFredId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
    ' b) Call the MessageBoxA
     APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
    End Sub
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 6+29=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Code:
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 5+30=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Private Function HoldYaBackCalledYaBackClapTrapRuc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long   '                                   ByVal CopyNumberFroNxtLvl As Long) As Long
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog + 1: Debug.Print " Going a HoldYaBackCalledYaBackClapTrapRuc"; GlobinalCntChopsLog; "(1Msg"; lMsg; ", wParam"; wParam; ", lParam"; lParam; ") Function Copy Number_"; GlobinalCntChopsLog
                                'If GlobinalCntChopsLog = 2 Then Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1: UnHookWindowsHookCodEx hHookTrapCrapNumber: Exit Function
        If lMsg = 5 Then '_-.... ( Hook type: HCBT_ACTIVATE = 5 but not here?) ... this runs a further 29 copies of HoldYaBackCalledYaBackClapTrap all coming here, so 30 times in total
                                Debug.Print "Expose Interface"; Tab(30); GlobinalCntChopsLog
         Call SetWindowPosition(wParam, 0, poX, pussY, 400, 150, 40) '             SWP_NOZORDER is 4 ..  but not here?? 'SWP_NOSIZE + SWP_NOZORDER ' Pull the Chainge position ...
         UnHookWindowsHookCodEx hHookTrapCrapNumber         ' Release the Hook 30 times this is done
        Else
                                Debug.Print "No InterOfCourse"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        End If ' 5 times here then '_-....
                                Debug.Print "Wipe chain WRap"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        Let HoldYaBackCalledYaBackClapTrapRuc = 0 '  Done  5+30=35 times in total  '0 (or False) makes it work, all other numbers and I get no Message box
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1
    End Function ' HoldYaBackCalledYaBackClapTrapRuc
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  9. #19
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    complete-page-numbers elided to non elided wonkie poos

    Code solution for this Thread
    http://www.excelfox.com/forum/showth...e-page-numbers
    https://www.excelforum.com/excel-pro...d-numbers.html



    Code:
    Option Explicit
    Sub Moshe() ' http://www.excelfox.com/forum/showthread.php/2229-complete-page-numbers
    Rem 1 Make array for holding inoput data and output data -  ' Input data can be handled as simple text so Array work is satisfactory
    Dim arrIn() As Variant ' We know the data type can be taken as string, but I want to get the data quickly in a spreadsheet "capture" type way, using the .Value Property applied to a range object which returns a field of values for more than 1 cell returns a field of values held in Variant types, - so the type must be variant or a type mismatch runtime error will occcur
     Let arrIn() = Range("A1:A" & Range("A1").CurrentRegion.Rows.Count & "").Value
    Dim arrOut() As String: ReDim arrOut(1 To UBound(arrIn())) ' I can use string type to suit my final data. I also know the array size, but I must make the array a dynamic ( unknown size ) type as the Dim declare statement will only take actual numbers, but I determine my size from the size of the input array by UBound(arrIn()) : the ReDim method will accept the UBound(arrIn()) , wheras the Dim declaration syntax will not accept this, as the Dim is done at complie and not runtime
    Rem 2 Effectively looping for each data row
    Dim Cnt As Long ' For going through each "row"
        For Cnt = 1 To UBound(arrIn()) ' Going through each element in arrIn()
        '2a) split the data in a cell into an array of data. The VBA strings collection split function will return a 1 dimentsional array of string types starting at indicie 0
        Dim spltEnt() As String ' For the string row split into each number entry, in other words an array of the data in a cell
            If InStr(1, arrIn(Cnt, 1), ", ", vbBinaryCompare) <> 0 Then ' case more than 1 entry in cell. starting at the first character  ,   in the current Cnt array element  , I look for  ", "   , stipulating an excact computer match search type         This Function will return eitheer the position counting from the left that it finds the first ", " or it will return 0 if it does not find at least one occurance of the ", "
             Let spltEnt() = VBA.Strings.Split(arrIn(Cnt, 1), ", ", -1, vbBinaryCompare) ' we now have a number or number pair
            Else ' case a single entry I cannot split by a ", " as i don't have any, ...
             ReDim spltEnt(0): Let spltEnt(0) = arrIn(Cnt, 1) ' ... so i just make a single element array and put the single element in it
            End If
        '2b) working through each data part in a cell
        Dim strOut As String 'String in each "row" '_-"Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular "Value", or ("Values" for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
        Dim CntX As Long '                         '_-Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in.  '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )       https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
            For CntX = 0 To UBound(spltEnt()) ' for going through each entry in a row in other words for going through each piece of data in a cell
            '2c)(i) case just data for a single page
                If InStr(1, spltEnt(CntX), "-", vbBinaryCompare) = 0 Then ' case of no "-"
                 Let strOut = strOut & spltEnt(CntX) & ", " ' just the single number goes in the output string, strOut
                Else ' we have a "-"
                Dim NmbrPear() As String ' this will be am Array of 2 elements for each number pair
                 Let NmbrPear() = VBA.Strings.Split(spltEnt(CntX), "-", -1, vbBinaryCompare)
                 '2c)(ii) case no correction needed in the data
                    If Len(NmbrPear(0)) = Len(NmbrPear(1)) Then ' the numbers are the same
                     Let strOut = strOut & spltEnt(CntX) & ", "  ' the same number pair goes in the output string
                    Else ' from here on, we need to do some adjustment before adding to the output string
                 '2c)(iii) cases data correction needed
                     Select Case Len(NmbrPear(0)) - Len(NmbrPear(1)) ' selecting the case of the difference in length of the two parts of the data "FirstNumberPart-SecondNumberPart"
                      Case 1 ' Like 123-24 or 12345-2345
                       Let NmbrPear(1) = VBA.Strings.Mid$(NmbrPear(0), 1, 1) & NmbrPear(1) ' like 1 & 24 or 1 & 2345 ' VBA strings collection Mid Function: This returns the part of  (   NmbrPear(0)    ,   the starts at character 1    ,    and has the length of 1 character     )
                      Case 2 ' like 123-4
                       Let NmbrPear(1) = VBA.Strings.Mid$(NmbrPear(0), 1, 2) & NmbrPear(1) ' like 12 & 4
                      Case 3 ' like 1234-6
                       Let NmbrPear(1) = VBA.Strings.Mid$(NmbrPear(0), 1, 3) & NmbrPear(1) ' like 123 & 6
                      Case 3 ' like 12345-8
                       Let NmbrPear(1) = VBA.Strings.Mid$(NmbrPear(0), 1, 4) & NmbrPear(1) ' like 1234 & 8
                     End Select ' at this point we have corrected our second number part from the pair
                    Let strOut = strOut & VBA.Strings.Join(NmbrPear(), "-") & ", " ' The number pair is rejoined with the corrected second number part before adding the number parts pair to the output string
                    End If
                 End If
            Next CntX
        '2d) The string of corrected data can now be added to the array for output
         Let strOut = VBA.Strings.Left$(strOut, Len(strOut) - 2) ' This removes the last unwanted ", "   ' 'VBA Strings collection Left function returns a Variant- initially tries to coerces the first parameter into Variant, Left$ does not, that's why Left$ is preferable over Left, it's theoretically slightly more efficient, as it avoids the overhead/inefficieny associated with the Variant. It allows a Null to be returned if a Null is given. https://www.excelforum.com/excel-new...ml#post4084816 .. it is all to do with ya .."Null propagation".. maties ;) '_-.. http://allenbrowne.com/casu-12.html Null is a special "I do not know, / answer unknown" - handy to hav... propogetion wonks - math things like = 1+2+Null returns you null. Or string manipulation stuff like, left(Null returns you Null. Count things like Cnt (x,y,Null) will return 2 - there are two known things there..Hmm - bit iffy although you could argue that Null has not been entered yet.. may never
         Let arrOut(Cnt) = strOut ' Finally the string is aded to the current "row" in the  outout array
         Let strOut = "" ' Empty variable holding a row string for use ijn next loop
        Next Cnt
    Rem 3 I have the final data array, and so umst now paste it out where I want it.
    Dim arrClmOut() As String: ReDim arrClmOut(1 To UBound(arrOut), 1 To 1) ' This is for a 1 column 2 Dimensional array which I need for the orientation of my final output
    '3(i) a simple loop to fill the transposed array
    Dim rCnt As Long '
        For rCnt = 1 To UBound(arrOut())
         Let arrClmOut(rCnt, 1) = arrOut(rCnt)
        Next rCnt
    '3(ii) Output to worksheet
     Let Range("B1").Resize(UBound(arrOut())).Value = arrClmOut() ' The cell Top left of where the output should go is resized to the required row size, and 1 column. The .Value Property of that range object may have the values in an Array assigned to it in a simpla one line assignment
    End Sub
    '
    '
    '
    '   http://www.excelfox.com/forum/showthread.php/2157-Re-Defining-multiple-variables-in-VBA?p=10192#post10192
    '   https://www.excelforum.com/word-programming-vba-macros/1175184-vba-word-repeat-character-in-string-a-number-of-times.html#post4591171
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  10. #20
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Function CStrSepDbl Excel VBA comma point thousand decimal separator number problem

    Code for this Thread:
    http://www.excelfox.com/forum/showth...0503#post10503
    http://www.excelfox.com/forum/forumd...ips-and-Tricks


    Function CStrSepDbl
    Code:
    '10   '   http://www.eileenslounge.com/viewtopic.php?f=27&t=22850#p208624
    Function CStrSepDbl(Optional ByVal strNumber As String) As Double '    Return a Double based on a String Input which is asssumed to "Look" like a Number. The code will work for Leading and Trailing zeros, but will not return them. )
    20   Rem 0        At the Dim stage  a  '_-String  is "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular “Value”, or (“Values” for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks, But http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
    30     If StrPtr(strNumber) = 0 Then Let CStrSepDbl = "9999999999": Exit Function '_- StrPtr(MyVaraibleNotYetUsed)=0 ..  http://www.excelfox.com/forum/showthread.php/1828-How-To-React-To-The-Cancel-Button-in-a-VB-(not-Application)-InputBox?p=10463#post10463       https://www.mrexcel.com/forum/excel-questions/35206-test-inputbox-cancel-2.html?highlight=strptr#post2845398    https://www.mrexcel.com/forum/excel-questions/917689-passing-array-class-byval-byref.html#post4412382
    40   Rem 1  'Adding a leading zero if no number before a comma or point, change all seperators to comma  ,
    50     If VBA.Strings.Left$(strNumber, 1) = "," Or VBA.Strings.Left$(strNumber, 1) = "." Then Let strNumber = "0" & strNumber  ' case for like .12  or ,7   etc 'VBA Strings collection Left function returns a Variant- initially tries to coerces the first parameter into Variant, Left$ does not, that's why Left$ is preferable over Left, it's theoretically slightly more efficient, as it avoids the overhead/inefficieny associated with the Variant. It allows a Null to be returned if a Null is given. https://www.excelforum.com/excel-new...ml#post4084816 .. it is all to do with ya .."Null propagation".. maties ;) '_-.. http://allenbrowne.com/casu-12.html Null is a special "I do not know, / answer unknown" - handy to hav... propogetion wonks - math things like = 1+2+Null returns you null. Or string manipulation stuff like, left(Null returns you Null. Count things like Cnt (x,y,Null) will return 2 - there are two known things there..Hmm -bit iffy although you could argue that Null has not been entered yet..may never
    60     If VBA.Strings.Left$(strNumber, 2) = "-," Or VBA.Strings.Left$(strNumber, 2) = "-." Then Let strNumber = Application.WorksheetFunction.Replace(strNumber, 1, 1, "-0") ' case for like  -.12  or -,274   etc
    70    Let strNumber = Replace(strNumber, ".", ",", 1, -1, vbBinaryCompare) 'Replace at start any . to a ,  After this point there should be either no or any amount of ,
    80     'Check If a Seperator is present, then MAIN CODE is done
    90     If InStr(1, strNumber, ",") > 0 Then 'Check we have at least one seperator, case we have, then..
    100  Rem 2 'MAIN CODE part ====
    110    'Length of String:  Position of last ( Decimal ) Seperator
    120    Dim LenstrNumber As Long: Let LenstrNumber = Len(strNumber): Dim posDecSep As Long: Let posDecSep = VBA.Strings.InStrRev(strNumber, ",", LenstrNumber) '  from right the positom "along" from left  (   (in strNumber)  ,  for a  (",")    ,   starting at the ( Last character ) which BTW. is the default
    130    'Whole Number Part
    140    Dim strHlNumber As String: Let strHlNumber = VBA.Strings.Left$(strNumber, (posDecSep - 1))
    150     Let strHlNumber = Replace(strHlNumber, ",", Empty, 1, -1) 'In (strHlNumber)   ,   I look for a (",")   ,    and replace it with "VBA Nothing there"    ,     considering and returning the strNumber from  the start of the string    ,     and replace all occurances ( -1 ).
    160    Dim HlNumber As Long: Let HlNumber = CLng(strHlNumber) 'Long Number is a Whole Number, no fractional Part
    170    'Fraction Part of Number
    180    Dim strFrction As String: Let strFrction = VBA.Strings.Mid$(strNumber, (posDecSep + 1), (LenstrNumber - posDecSep)) 'Part of string (strNumber )  ,  starting from just after Decimal separator  ,    and extending to a length of = ( the length  of the whole strNumber minus  the position of the separator )
    190    Dim LenstrFrction As Long: Let LenstrFrction = Len(strFrction) 'Digits after Seperator. This must be done at the String Stage, as length of Long, Double etc will allways be 8, I think?.
    200    Dim Frction As Double: Let Frction = CDbl(strFrction) 'This will convert to a Whole Double Number. Double Number can have  Fractional part
    210     Let Frction = Frction * 1 / (10 ^ (LenstrFrction)) 'Use 1/___, rather than a x 0.1 or 0,1 so as not to add another , . uncertainty!!
    220    'Re join, using Maths to hopefully get correct Final Value
    230    Dim DblReturn As Double 'Double Number to be returned in required Format after maniplulation.
    240         If Left(strHlNumber, 1) <> "-" Then 'Case positive number
    250          Let DblReturn = CDbl(HlNumber) + Frction 'Hopefully a simple Mathematics + will give the correct Double Number back
    260         Else 'Case -ve Number
    270          Let strHlNumber = Replace(strHlNumber, "-", "", 1, 1, vbBinaryCompare) ' strHlNumber * (-1) ' "Remove" -ve sign
    280          Let DblReturn = (-1) * (CDbl(strHlNumber) + Frction) 'having constructed the value of the final Number we multiply by -1 to put the Minus sign back
    290         End If 'End checking polarity.
    300    'Final Code Line(s)   At this point we have what we want. We need to place this in the "Double Type variable" , CStrSepDbl , so that an assinment like    = CStrSepDbl( ) will return this final value
    310     Let CStrSepDbl = DblReturn 'Final Double value to be returned by Function
    320    Else 'End MAIN CODE. === We came here if we have a Whole Number with no seperator, case no seperator
    330    'Simple conversion of a string "Number" with no Decimal Seperator to Double Format
    340     Let CStrSepDbl = CDbl(strNumber) 'String to be returned by Function is here just a simple convert to Double ' I guess this will convert a zero length string "" to 0 also
    350    End If 'End checking for if a Seperator is present.
    End Function
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    'Long code lines:  Referrences    http://www.mrexcel.com/forum/about-board/830361-board-wish-list-2.html          http://www.mrexcel.com/forum/test-here/928092-http://www.eileenslounge.com/viewtopic.php?f=27&t=22850
    Function CStrSepDblshg(strNumber As String) As Double '          http://excelxor.com/2014/09/05/index-returning-an-array-of-values/      http://www.techonthenet.com/excel/formulas/split.php
    5      If Left(strNumber, 1) = "," Or Left(strNumber, 1) = "." Then Let strNumber = "0" & strNumber
    20   Let strNumber = Replace(strNumber, ".", ",", 1, -1)
    40     If InStr(1, strNumber, ",") > 0 Then
    170         If Left(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1), 1) <> "-" Then
    180          Let CStrSepDblshg = CDbl(CLng(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1))) + CDbl(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))) * 1 / (10 ^ (Len(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber)))))))
    190         Else
    210          Let CStrSepDblshg = (-1) * (CDbl(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1) * (-1)) + CDbl(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))) * 1 / (10 ^ (Len(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))))))
    220         End If
    250    Else
    270     Let CStrSepDblshg = CDbl(strNumber)
    280    End If
    End Function
    Demo Code to call Function
    Code:
    Sub TestieCStrSepDbl() ' using adeptly named  TabulatorSyncranartor ' / Introducing LSet TabulatorSyncranartor Statement :   http://www.excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Dim LooksLikeANumber(1 To 17) As String
     Let LooksLikeANumber(1) = "001,456"
     Let LooksLikeANumber(2) = "1.0007"
     Let LooksLikeANumber(3) = "123,456.2"
     Let LooksLikeANumber(4) = "0023.345,0"
     Let LooksLikeANumber(5) = "-0023.345,0"
     Let LooksLikeANumber(6) = "1.007"
     Let LooksLikeANumber(7) = "1.3456"
     Let LooksLikeANumber(8) = "1,2345"
     Let LooksLikeANumber(9) = "01,0700000"
     Let LooksLikeANumber(10) = "1.3456"
     Let LooksLikeANumber(11) = "1,2345"
     Let LooksLikeANumber(12) = ".2345"
     Let LooksLikeANumber(13) = ",4567"
     Let LooksLikeANumber(14) = "-,340"
     Let LooksLikeANumber(15) = "00.04"
     Let LooksLikeANumber(16) = "-0,56000000"
     Let LooksLikeANumber(17) = "-,56000001"
    Dim Stear As Variant, MyStringsOut As String
        For Each Stear In LooksLikeANumber()
        Dim Retn As Double
         Let Retn = CStrSepDbl(Stear)
        Dim TabulatorSyncranartor As String: Let TabulatorSyncranartor = "                         "
         LSet TabulatorSyncranartor = Stear
         Let MyStringsOut = MyStringsOut & TabulatorSyncranartor & Retn & vbCrLf
         Debug.Print Stear; Tab(15); Retn
        Next Stear
     MsgBox MyStringsOut
    End Sub



    Code also Here:
    https://pastebin.com/1kq6h9Bn
    Last edited by DocAElstein; 02-17-2018 at 06:05 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

Similar Threads

  1. VBA to Reply All To Latest Email Thread
    By pkearney10 in forum Outlook Help
    Replies: 11
    Last Post: 12-22-2020, 11:15 PM
  2. Appendix Thread. Diet Protokol Coding Adaptions
    By DocAElstein in forum Test Area
    Replies: 6
    Last Post: 09-05-2019, 10:45 AM
  3. Replies: 19
    Last Post: 04-20-2019, 02:38 PM
  4. Search List of my codes
    By PcMax in forum Excel Help
    Replies: 6
    Last Post: 08-03-2014, 08:38 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •