Notes tests. Excel VBA Folder File Search

[DocAElstein]

Re: Appendix Thread. ( Codes for other Threads, HTML Tables, etc. )<o:p></o:p>
<o:p> </o:p>
Hi<o:p></o:p>
. I would like to use this Thread as an Appendix for codes in other Threads so as to help reduce clutter in that Thread should the code be a bit long, or not directly relevant.<o:p></o:p>
. Also as HTML code is on in this Test Sub Forum I would like to reference HTML Tables should I wish to use them in answering threads<o:p></o:p>
<o:p> </o:p>
@ Moderators, Administrator:<o:p></o:p>
. I hope the above is OK to do and if so please do not delete this Thread. ( Or advise if I should post my "Appendix" somewhere else ( If possible where HTML code is on ) )<o:p></o:p>
.<o:p></o:p>
. Many Thanks<o:p></o:p>
Alan<o:p></o:p>



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vOQApTgb (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vOQApTgb)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vbihZ-7W (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vbihZ-7W)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vfmpSO0F (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vfmpSO0F)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vjfTJ7lX (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vjfTJ7lX)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vmq-LHHz (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vmq-LHHz)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vst3j_7i (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9c-vst3j_7i)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwBqjIR5 Nj (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwBqjIR5 Nj)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwBw8El0 r5 (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwBw8El0 r5)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwC63GbR uM (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwC63GbR uM)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwC9fyKZ do (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwC9fyKZ do)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwCEn8DB Qe (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bwCEn8DB Qe)
https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bw0Bey8g QO (https://www.youtube.com/watch?v=nVy4GAtkh7Q&lc=UgxJGNhWFZh2p5mK0XB4AaABAg.9bbxud383FI9bw0Bey8g QO)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Coding for these Threads
https://stackoverflow.com/questions/31439866/multiple-variable-arguments-to-application-ontime
http://www.excelfox.com/forum/showthread.php/2404-Notes-tests-Application-Run-OnTime-Multiple-Variable-Arguments-ByRef-ByVal?p=11870&viewfull=1#post11870
https://stackoverflow.com/questions/31439866/multiple-variable-arguments-to-application-ontime/59812342#59812342

Open workbook - MainFile.xls : https://app.box.com/s/prqhroiqcb0qccewz5si0h5kslsw5i5h

Module "Modul1" in MainFile.xls
(This is the main module from which all macros are run)



Option Explicit
' Public variable code section
Private Pbic_Arg1 As String
Public Pbic_Arg2 As Double


Dim sTemp As String
' _
_


Sub MainMacro() ' https://stackoverflow.com/questions/31439866/multiple-variable-arguments-to-application-ontime/31464597 http://markrowlinson.co.uk/articles.php?id=10
Rem 1
Debug.Print "Rem 1" & vbCr & vbLf & "This workbook module, single arrgument"
' This workbook module, single argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderMainMacro 465'": Debug.Print "!'Modul1.UnderMainMacro 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderMainMacro ""465""'": Debug.Print "!'Modul1.UnderMainMacro ""465""'"
Application.OnTime Now(), "'Modul1.UnderMainMacro 465'" ' --- more usual simplified form. In this case I nned the extra Modul1. because Sub UnderMainMacro( ) is private
Debug.Print vbCr & vbLf & "UverFile module, single argument"
' UverFile module, single argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroInUverFile 465'": Debug.Print "!'Modul1.MacroInUverFile 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroInUverFile ""465""'": Debug.Print "!'Modul1.MacroInUverFile ""465""'"
Debug.Print vbCr & vbLf & "Thisworkbook module, multiple arguments"
' Thisworkbook module, multiple arguments
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465, 25'": Debug.Print "!'Modul1.UnderUnderMainMacro 465, 25'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465, ""25""'": Debug.Print "!'Modul1.UnderUnderMainMacro 465, ""25""' "
Application.OnTime Now(), "'UnderUnderMainMacro 465, 25 '" ' --- more usual simplified form. I don't even need the extra Modul1. because it is not private
Debug.Print vbCr & vbLf & "UverFile module, multiple argument"
' UverFile module, multiple argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroUnderMacroInUverFile 465, 25'": Debug.Print "!'Modul1.MacroUnderMacroInUverFile 465, 25'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroUndermacroInUverFile 465, ""25""'": Debug.Print "!'Modul1.MacroUndermacroInUverFile 465, ""25""'"
Debug.Print vbCr & vbLf & "mess about with argument positions"
' mess about with argument positions
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465 , ""25"" '": Debug.Print "!'Modul1.UnderUnderMainMacro 465 , ""25"" '"
Debug.Print vbCr & vbLf & "This workbook first worksheet code module, single arrgument"
' This workbook first worksheet code module, single arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModule 465'": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModule 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModule ""465""'": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModule ""465""'"
Debug.Print vbCr & vbLf & "UverFile first worksheet code module, single arrgument"
' UverFile first worksheet code module, single arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule 465'": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule ""465""'": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule ""465""'"
Debug.Print vbCr & vbLf & "This workbook first worksheet code module, multiple arguments"
' This workbook first worksheet code module, multiple arguments
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModuleMultipleArguments 465 , ""25"" '": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModuleMultipleArguments 465 , ""25"" '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModuleMultipleArguments ""465"" , 25 '": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModuleMultipleArguments ""465"" , 25 '"
Debug.Print vbCr & vbLf & "UverFile first worksheet code module, Multiple arrgument"
' UverFile first worksheet code module, Multiple arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments 465 , ""25"" '": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments 465 , ""25"" '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments ""465"" , ""25"" '": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments ""465"" , ""25"" '"
Debug.Print vbCr & vbLf & "Doubles do not have to be in quotes either ' This workbook module, double argument arrgument"
' Doubles do not have to be in quotes either ' This workbook module, double argument arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck 465.5 , ""25.4"" '": Debug.Print "!'Modul1.DoubleCheck 465.5 , ""25.4"" '"

Rem 2 Variables
Debug.Print vbCr & vbLf & "Rem 2 Variables" & vbCr & vbLf & "'2a) ""Pseudo"" variables use"
'2a) "Pseudo" variables use
Dim Arg1_str465 As String, Arg2_Dbl25 As Double
Let Arg1_str465 = "465.42": Let Arg2_Dbl25 = 25.4
' Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Arg1_str465 , Arg2_Dbl25 '": Debug.Print "!'Modul1.DoubleCheck Arg1_str465 , Arg2Db_l25 '" ' This code line will not work, that is to say it will not find the varables and take 0 values when VBA later runs the Scheduled macro, Sub DoubleCheck( )
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , """ & Arg2_Dbl25 & """ '": Debug.Print "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , """ & Arg2_Dbl25 & """ '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , " & Arg2_Dbl25 & " '": Debug.Print "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , " & Arg2_Dbl25 & " '"
Debug.Print vbCr & vbLf & "'2b) Real varable use"
'2b) Real varable use
Let Modul1.Pbic_Arg1 = "465.42": Let Pbic_Arg2 = 25.4
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Modul1.Pbic_Arg1 , Pbic_Arg2 '": Debug.Print "!'Modul1.DoubleCheck Modul1.Pbic_Arg1 , Pbic_Arg2 '"

Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Modul1.Pbic_Arg1, Pbic_Arg2'"
'' Debug.Print Pbic_Arg2 '' This gives 999.99 in Debug F8 mode , 25.4 in normal run

Rem 3 ByRef check
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
Application.OnTime Now() + TimeValue("00:00:00"), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
End Sub
Private Sub UnderMainMacro(ByVal Nmbr As Long)
MsgBox prompt:="Arg1 is " & Nmbr
End Sub
Sub UnderUnderMainMacro(ByVal Nmbr As Long, ByVal NuverNmbr As Long)
MsgBox prompt:="Arg1 is " & Nmbr & ", Arg2 is " & NuverNmbr
End Sub
Sub DoubleCheck(ByVal DblNmr1 As Double, ByRef DblNmr2 As Double) ' provided the signature line is declared appropriately, all number argument types dont have to be in ""
MsgBox prompt:="Arg1 is " & DblNmr1 & ", Arg2 is " & DblNmr2
Let DblNmr2 = 999.99
End Sub


Sub ByRefCheck()
Debug.Print vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Rem 3 ByRef Check" & vbCr & vbLf & Pbic_Arg2
End Sub

[DocAElstein]

Function Code for getting Column Letter from Column Number
Shortened version used in Post #14
http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9837#post9837
Public Function CL(ByVal lclm As Long) As String

And Fuller version with explaining 'Comments



Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

Function FukOutChrWithDoWhile(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 FukOutChrWithDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & FukOutChrWithDoWhile
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
Rem Ref http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Rem Ref http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html

[DocAElstein]

The code to step through while reading Posts from
http://www.excelfox.com/forum/showthread.php/2042-Special-concatenation?p=9517#post9517
from Post #25 http://www.excelfox.com/forum/showthread.php/2042-Special-concatenation/page3
http://www.excelfox.com/forum/f2/special-concatenation-2042/index3.html


Sub EvalutingQuotes() 'Posts from #25 http://www.excelfox.com/forum/f2/special-concatenation-2042/index3.html

Rem 1) Basics
Dim v As Variant
Let v = "3" ' Results in a Variant variable containing a string value "3"
Let v = 3 ' Results in a Variant variable containing a Long Number 3 ( actually an Integer ? )

Range("I1").Value = Evaluate("=A1") 'Explicit Version
Range("I1").Value = Evaluate("=" & Range("A1").Address & "") 'Explicit Version
Range("I1").Value = Evaluate("" & Range("A1").Address & "") 'Implicit Default

Range("I1").Value = Evaluate(" " & Range("A1").Address & " ") '

Range("I1").Value = Evaluate(Range("A1").Address) 'Common but dangerous variation

Rem 2) Detailed code anylysis
Dim strEval As String 'String to be used in Evaluate

10 strEval = "=A1" & "&" & "A1": Debug.Print strEval 'gives =A1&A1
Range("I1").Value = Evaluate("" & strEval & "") 'Result Gives 11 in cell I1

20 'strEval = "=A1" & "&"" & ";" & ""&" & "A1": Debug.Print strEval 'gives syntax error
'Range("I1").Value = Evaluate("" & strEval & "") 'errors

30 strEval = "=A1" & "&"";""&" & "A1": Debug.Print strEval 'gives =A1&";"&A1
Range("I1").Value = Evaluate("" & strEval & "") 'Result Gives 1;1

40 strEval = "=A1" & "&"";""": Debug.Print strEval 'gives =A1&";"
Range("I1").Value = Evaluate("" & strEval & "") 'Gives 1;

50 strEval = "=A1" & "&"";" & """": Debug.Print strEval 'gives =A1&";"
Range("I1").Value = Evaluate("" & strEval & "") 'Gives 1;

60 strEval = "=A1" & "&"";""""" & """": Debug.Print strEval 'gives =A1&";" ""
Range("I1").Value = Evaluate("" & strEval & "") 'error
70 strEval = "=A1" & "&"";"";""" & """": Debug.Print strEval 'gives=A1&";";""
Range("I1").Value = Evaluate("" & strEval & "") 'error

80 strEval = "=A1" & "&"";""""" & """": Debug.Print strEval 'gives =A1&";"""
Range("I1").Value = Evaluate("" & strEval & "") 'Did not error Gives 1;" !!!!!!!!

90 strEval = "=A1" & "&"";""" & """" & """": Debug.Print strEval 'gives =A1&";"""
Range("I1").Value = Evaluate("" & strEval & "") 'Did not error Gives 1;" !!!!!!!!

Rem 3
100 strEval = "=A1" & "&"";""""""": Debug.Print strEval 'gives =A1&";"""
Range("I1").Value = Evaluate("" & strEval & "") 'Did not error Gives 1;" !!!!!!!!


End Sub

[DocAElstein]

Obtaining grid coordinates for an Area of contiguous cells in a Spreadsheet using [ ] and Evaluate(“ “) through the use of a Named Range for that Area

Aka ' It is a Range Name Test : Its n Range Name Test : 's 'n Rng Name Test : s n Rg Name Testie : snRg.Name = "snRgNme"
This code is in support of other Posts in various Threads. ( I will edit the Links as I reference this post )
For example:
http://www.excelforum.com/showthread.php?t=1141369&p=4400666&highlight=#post4400666




The code takes in a hard coded Range, A1:E10.
That Range is given a Name as held in the Names Register of a Worksheet.
Various code lines are developed which reference this Named Range and return the Grid Coordinates.

These coordinates are held within the following Long Type Variables
Cs is the start column
sClm is the column count
stpClm is the stop column
Rs is the start row
sRw is the rows count
stpRw is the stop row



'10 ' It is a Range Name Test : Its n Range Name Test : 's 'n Rng Name Test : s n Rg Name Testie : snRg.Name = "snRgNme"
Sub snRgNameTest() ' Inspired by.. snb .. " array [ ] " ' http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9714#post9714
20 ' Worksheets Info
30 Dim ws As Worksheet ' ' Preparing a "Pointer" to an Initial "Blue Print" ( or a Form, or a Questionnaire not yet filled in, a template etc.) in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Object of this type ) . This also us to get easily at the Methods and Properties through the applying of a period ( .Dot) ( intellisense )
40 'Set ws = ThisWorkbook.Worksheets("NPueyoGyanArraySlicing") 'The worksheets collection object is used to Set ws to the Sheet we are playing with, so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
50 Set ws = ActiveSheet ' Alternative to last line, make code apply to the current active sheet, - That being "looked at" when running this code '
60 Dim vTemp As Variant ' To help development when you are not sure what type is retuned. "Suck and see what comnes out!" Highlight it and Hit Shift+F9 to see it in the imediate Window
70 ' Named range referrencing Invoke Pike Evaluate Rabbit Rabbit. How's the Bunny ? Bunnytations Banters
80 Dim snRg As Range: Set snRg = ws.Range("A1:E10")
90 Dim sName As String: Let sName = "snRgNme" '
100 Let snRg.Name = "snRgNme" ' It is a Range Name me - " 's 'n Range Name me " .. "snRgNme" ;) This name appears permanentlly in then sheet. It remains referrencing this range unless the name iis deleted or the range referrenced is overwritten by a similar code line which has a different range in it on RHS of = http://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
110 Let snRg.Name = sName ' Identical to last line
120 Dim ReturnedsnRgName As String
130 Let ReturnedsnRgName = snRg.Name ' The returned name is full, like "NPueyoGyanArraySlicing!$A$1:$E$10". This will not work in the Address Formulas
140 Dim NameOnly As String: Let NameOnly = Replace((snRg.Name), "!", "", (InStr(1, (snRg.Name), "!"))): Debug.Print snRg.Name: Dim pos&: pos = InStr(1, (snRg.Name), "!"): NameOnly = Replace((snRg.Name), "!", "", pos) ' We had ---- "NPueyoGyanArraySlicing!$A$1:$E$10" so here I return a string that starts at the position of the ! and which replaces in that truncated shortened string - "!$A$1:$E$10" the "!" with nothing
150 Let NameOnly = Replace((ReturnedsnRgName), "!", "", (InStr(1, (ReturnedsnRgName), "!")))
160 If InStr(NameOnly, "!") > 0 Then MsgBox prompt:="NameOnly is " & vbCr & """" & NameOnly & """" & vbCr & "so will chop off up to and including the ""!""": Let NameOnly = Replace((NameOnly), "!", "", (InStr(1, (NameOnly), "!"))) ' Just to demo that you need to do this if you are not sure that a ! is there, or the code line would error if no ! was in there..
170 '
180 ' Count, Start, and Stop of columns in an Area of contiguous cells in a Spreadsheet
190 Dim sClm As Long 'Variable for ColumnsCount. -This makes a Pigeon Hole 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. Long is very simple to handle, final memory "size" type is known (13.456, 00.001 have same "size" computer memory ),so an Address suggestion can be given for 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 anyway, so a Long is actually faster)
200 Let sClm = Evaluate("columns(snRgNme)") ' = 5
210 'Let sClm = Evaluate("columns(RetunedsnRgName)") 'Run time Error as expected
220 Let sClm = [columns(snRgNme)] ' = 5 'Is this Most Powerful Command in VBA?, or what ... http://www.ozgrid.com/forum/showthread.php?t=52372 http://www.mrexcel.com/forum/excel-questions/899117-visual-basic-applications-range-a1-a5-vs-%5Ba1-a5%5D-benefits-dangers.html
230 'Let sClm = [columns(RetunedsnRgName)] 'Run time Error as expected
240 Let sClm = [columns(A1:E10)] ' = 5
250 Let vTemp = Evaluate("column(snRgNme)") ' Reveals an Array {1, 2, 3, 4, 5} - 1 Dimension "pseudo Horizontal" Array
260 Dim Cs As Long 'Variable for Start Column
270 Let Cs = Evaluate("column(A1:E10)")(1)
280 Let Cs = Evaluate("column(snRgNme)")(1) ' = 1
290 Let vTemp = [column(snRgNme)]: vTemp = vTemp(1) ' Anololie erklart: http://www.excelforum.com/showthread.php?t=1141369&p=4398930&highlight=#post4398930 http://www.excelforum.com/showthread.php?t=1141369&p=4398966#post4398966
300 Let Cs = [column(A1:E10)]()(1)
310 Let Cs = [column(snRgNme)]()(1)
320 '
330 Dim stpClm% ' Variable for Stop column Number ' ( % is shorthand for As Long ..http://www.excelforum.com/showthread.php?t=1116127&p=4256569#post4256569
340 Let stpClm = Cs + (sClm - 1) ' = 5
350 ' [ ]
360 Let stpClm = [column(snRgNme)]()(1) + ([columns(snRgNme)] - 1)
370 Let stpClm = [column(snRgNme)]()(1) + ([columns(snRgNme)] - 1)
380 ' In between step [ ] and Evaluate(" ")
390 Let stpClm = [column(snRgNme)]()(UBound([column(snRgNme)]))
400 ' Now Full Evaluate(" ")
410 Let stpClm = Evaluate("column(snRgNme)")(1) + (Evaluate("columns(snRgNme)") - 1)
420 Let stpClm = Evaluate("column(snRgNme)")(UBound(Evaluate("column(snRgNme)")))
430 '
440 ' Start, Count and Stop of rows in an Area of contiguous cells in a Spreadsheet
450 Dim sRw As Long 'Rows Count
460 Let sRw = Evaluate("rows(snRgNme)")
470 Let sRw = [rows(snRgNme)]
480 Let sRw = [rows(A1:E10)]
490 Let vTemp = Evaluate("row(snRgNme)") ' = {1; 2; 3; 4; 5; 6; 7; 8; 9; 10}
500 Dim Rs As Long 'Start Row
510 Let Rs = Evaluate("row(A1:E10)")(1, 1) 'Note a 2 Dimensional, 1 column, "vertical" Array is returned : ' vTemp = {1; 2; 3; 4; 5; 6; 7; 8; 9; 10}
520 Let Rs = Evaluate("row(snRgNme)")(1, 1)
530 Let vTemp = [row(snRgNme)]: vTemp = vTemp(1, 1)
540 Let Rs = [row(A1:E10)]()(1, 1)
550 Let Rs = [row(snRgNme)]()(1, 1)
560 '
570 Dim stpRw% 'Stop Row
580 Let stpRw = Rs + (sRw - 1)
590 Let stpRw = [row(snRgNme)]()(1, 1) + ([rows(snRgNme)] - 1)
600 Let stpRw = [row(snRgNme)]()(1, 1) + ([rows(snRgNme)] - 1)
610 '
620 Let stpRw = [row(snRgNme)]()(UBound([row(snRgNme)], 1), 1) 'UBound([row(snRgNme)], 1) is Ubound first ( "row" ) dimension. UBound([row(snRgNme)], 2) would be the second dimension ( "column" ) count
630 '
640 Let stpRw = Evaluate("row(snRgNme)")(1, 1) + (Evaluate("rows(snRgNme)") - 1)
650 Let stpRw = Evaluate("row(snRgNme)")(UBound(Evaluate("row(snRgNme)")), 1)
660 '
End Sub

[DocAElstein]

"Opened up" Rick code:

' To Test Function, Type some arbitrary values in range A1:E10, step through Test Code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17

(_... Original Code:
' http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9658#post9658
....)



' To Test Function, Type some arbitrary values in range A1:E10, step through Test Code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17
' http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9658#post9658
Sub Rick()
Dim sp() As Variant
Dim DataArr() As Variant: Let DataArr() = Range("A1:E10").Value
Let sp() = Fu_Rick(DataArr(), 5)
Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)).ClearContents
Let Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)) = sp()
End Sub


Required Function_...
Function Fu_Rick(ByRef arrIn() As Variant, ByVal RowToDelete As Long) As Variant
_... in next Post

[DocAElstein]

Function Required for last Post:



Function Fu_Rick(ByRef arrIn() As Variant, ByVal RowToDelete As Long) As Variant
10 ' use "neat magic" code line arrOut() = Application.Index(arrIn(), rwsT(), clms())
20 ' So we have directly the Input Array, arrIn(). For clms(), do some extra stuff to get a column letter ( usiing the Split Address Method ) then column indices diectly from Spreadsheet column() Function. Rows from joinig the Row indicies above and below the row to be deleted
30 Dim Cols As String: Cols = "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0)
40 ' Fu_Rick = Application.Index(arrIn(), Application.Transpose(Split(Join(Application.Trans pose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
50
60 ' clms() = { 1, 2, 3, 4, 5 }
61 'clms() Rick Evaluate("COLUMN(" & "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0) & ")")
70 ' Start point is last column in Output Array using.. Split Address technique http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213969
80 Dim larrClm As Long: Let larrClm = ((UBound(arrIn(), 2) - LBound(arrIn(), 2)) + 1) ' For our Output Array ( base 1 ) staring at 1 - not yet pinned to a Top left Output Range cell the ( ( stop "column" - start "column" ) + 1 ) gives "last" "column"
90 Dim AdrsRel As String: Let AdrsRel = Columns(larrClm).Address(ColumnAbsolute:=False) 'False absolute Address gives no $ prefix and format like "E:E" (true Relative Address) , so split by ":" and then either (0) or (1) returned arrAddressSplit() Element will do for the letter..
100 Dim arrAddressSplit() As String
110 Let arrAddressSplit() = VBA.Split(AdrsRel, ":", 2, vbTextCompare) 'Splits into like ("E", "E") for no or -1 second argument.. Here 2 gives just the 2 you would get E, and E - ... http://www.mrexcel.com/forum/general-excel-discussion-other-questions/929381-visual-basic-applications-split-function-third-argument-refers-maximum-outputs-%93when-splitting-stops-%94.html
120 Dim clmLtr As String
130 Let clmLtr = arrAddressSplit(0) 'Returns first element "along" in 1 Dimensional "Psuedo Horizontal" Array ( Elements for 1 Dimensional Array are by default 0,1, 2, 3 ....etc )
140 ' Now use spreadsheet column function , column(A:E"), to get a {1, 2, 3, 4, 5} Array
150 Dim clms() As Variant: Let clms() = Evaluate("column(A:" & clmLtr & ")")

160 'rwsT() Rick Application.Transpose(Split(Join(Application.Trans pose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")")))))
170 'Final required row Indicies, with a missing indicie, as 2 strings ( Hard Copy )
180 Dim strRwsDBelow As String, strRwsDAbove As String, strrwsD As String
190 Let strRwsDBelow = "1 2 3 4": Let strRwsDAbove = "6 7 8 9 10"
200 Let strrwsD = "1 2 3 4" & " " & "6 7 8 9 10"
210 Let strrwsD = strRwsDBelow & " " & strRwsDAbove
220
230
240 'Get row indicies conveniently from Row Function - ( correct "orintation" to use in "neat magic" code line, but wrong "orientation" to use Join Function {1; 2; 3; 4} and {6; 7; 8; 9; 10} )
250 Dim arr_2D1rowBelow() As Variant, arr_2D1rowAbove() As Variant
260 Let arr_2D1rowBelow() = Evaluate("Row(1:" & (RowToDelete - 1) & ")") ' 1 To 4, 1 To 1 {1; 2; 3; 4} Array
270 Let arr_2D1rowAbove() = Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")") ' 1 To 5, 1 To 1 {6; 7; 8; 9; 10} Array
280 'Get sequential below and above row strings.... transpose back again! so Join will work, dear oh dear.....
290 Let strRwsDBelow = Join(Evaluate("transpose(Row(1:" & (RowToDelete - 1) & "))"), " ") 'Join must have eindimensional Array, as given by transpose working on a 2D 1 column Array
300 Let strRwsDBelow = Join(Application.Transpose((Evaluate("Row(1:" & (RowToDelete - 1) & ")"))), " ") ' "1 2 3 4"
310 Let strRwsDBelow = Join(Application.Transpose((arr_2D1rowBelow())), " ") ' "1 2 3 4"
320 Let strRwsDAbove = Join(Application.Transpose((arr_2D1rowAbove())), " ") ' "6 7 8 9 10"

330 'Final required row Indicies, with a missing indicie, as a string
340 Let strrwsD = strRwsDBelow & " " & strRwsDAbove
350
360 'Split Final String by " " to get 1 1D "Pseudo Horizontal" Array
370 Dim rws() As String: Let rws() = VBA.Split(strrwsD, " ") ' 1 D Array
380 'final Transposed Array for "magic neat" code line
390 Dim rwsT() As Variant: Let rwsT() = Application.Transpose(rws()) ' 2 D 1 "column" Array
400
440 'Output Array
450 Dim arrOut() As Variant
460 Let arrOut() = Application.Index(arrIn(), rwsT(), clms())
470
480 Let Fu_Rick = arrOut()
490 'Or
Fu_Rick = Application.Index(arrIn(), Application.Transpose(Split(Join(Application.Trans pose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")"))))), Evaluate("COLUMN(" & "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0) & ")"))
End Function

[DocAElstein]

"Opened up" snb Code

(_.. Original code here
http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9714#post9714
_........)

' To Test Function, Type some arbitrary values in range A1:E10, step through code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17






' Delete One Row From a ... group of contiguous cells in a Spreadsheet

' To Test Function, Type some arbitrary values in range A1:E10, step through code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17
' http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9714#post9714
Sub snb_()
Dim sp() As Variant
Let sp() = Fu_snb(Range("A1:E10"), 5)
Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)).ClearContents
Let Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)) = sp
End Sub

Required Function_...
Function Fu_snb(ByVal sn As Range, ByVal y As Long) As Variant
_...in next Post

[DocAElstein]

Required Function for last Post


Function Fu_snb(ByVal sn As Range, ByVal y As Long) As Variant
10 ' use "neat magic" code line arrOut() = Application.Index(arrIn(), rwsT(), clms()) http://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html http://www.mrexcel.com/forum/excel-questions/908760-visual-basic-applications-copy-2-dimensional-array-into-1-dimensional-single-column-2.html#post4375354
20 ' So we have sn as a range sn, ( can be uses syntaxly for arrIn() in "neat magic" line. ). Consequtive columns indicies as simple transpose of consequtive row Indicies from Spreadsheet row Funnction. Row indicies as the consequtive row indicies with the row to be deleted taken out
30 ' so snb does arrOut() = Application.Index(sn, rwsT(), clms())
40
50
60 ' clms() = { 1, 2, 3, 4, 5 }
70 'clms()
80 Dim clms() As Variant: Let clms() = Evaluate("column(A1:E10)")
90 Let clms() = Evaluate("column(" & sn.Address & ")")
100 Dim sName As String: Let sName = "snb_002"
110 Let sn.Name = sName
120 Let clms() = Evaluate("column(" & sName & ")")
129 Let clms() = Evaluate("column(snb_002)")
130 '== DANGER: === Pitful: Above we gave the Range Object a Name, but now see what "Name" or "Name" 's comes back "!" !
132 Dim retRefstrName As String, retObjName As Object
133 Let retRefstrName = sn.Name: Set retObjName = sn.Name: Debug.Print sn.Name 'something of the form "NPueyoGyanArraySlicing!$A$1:$E$10" is reveald in Immediate ( Ctrl+G when in VB Editor ) Window
134 'Let clms() = Evaluate("column(=NPueyoGyanArraySlicing!$A$1:$E$10)") 'Let clms() = Evaluate("column(" & retRefstrName & ")")' Rintime Error 13: Incompatiblee types
135 Let clms() = Evaluate("column(NPueyoGyanArraySlicing!$A$1:$E$10)") 'Works
137 Dim NameOnly As String: Let NameOnly = Replace((sn.Name), "!", "", (InStr(1, (sn.Name), "!"))): 'Debug.Print sn.Name: Dim pos&: pos = InStr(1, (sn.Name), "!"): NameOnly = Replace((sn.Name), "!", "", pos) ' We had ---- "NPueyoGyanArraySlicing!$A$1:$E$10" This is a String referrece returned when the Name Object is used directly or set to a String Variable. so here I return a string that starts at the position of the ! and which replaces in that truncated shortened string - "!$A$1:$E$10" the "!" with nothing
138 Let clms() = Evaluate("column(" & NameOnly & ")"): Let clms() = Evaluate("column(" & Replace((sn.Name), "!", "", (InStr(1, (sn.Name), "!"))) & ")")
139
140 Dim strName As String: Let strName = sn.Name.Name: Debug.Print strName: Let strName = retObjName.Name: Debug.Print strName ' returns our original "CoN"
142 Let clms() = Evaluate("column(" & strName & ")")
150 Dim rngF1G2 As Range: Set rngF1G2 = Range("F1:G2"): Let Range("F1:G2").Value = "From Line 150"
151 Let Range("=NPueyoGyanArraySlicing!F1:G2").Value = "From Line 151"
152 Let rngF1G2.Name = "snFG": Let Range("snFG").Value = "From Line 152"
149 '===============
160 'rwsT() snb rws() = VBA.Split(Trim(Replace(" " & Join(Evaluate("transpose(row(A1:E10))")) & " ", " " & y & " ", " ")))
170 'Final required row Indicies, with a missing indicie, as a string ( Hard Copy )
180 Dim strrwsD As String
190 Let strrwsD = "1 2 3 4 6 7 8 9 10"
200 Let strrwsD = Replace("1 2 3 4 5 6 7 8 9 10", " 5 ", " ", 1)
210 Dim strRws As String: Let strRws = "1 2 3 4 5 6 7 8 9 10"
220 Let strrwsD = Replace(strRws, " 5 ", " ", 1)
230
240 'Get full sequential row conveniently from Row Function - ( correct "orientation" to use in "neat magic" code line, but wrong "orientation" to use Join Function {1; 2; 3; 4; 5; 6; 7; 8; 9; 10} )
250 Dim arr_2D1row() As Variant
260 Let arr_2D1row() = Evaluate("row(A1:E10)") ' 1 To 10, 1 To 1
270
280 'Get full sequential row string.
290 Let strRws = Join(Evaluate("transpose(row(A1:E10))"), " ") 'Join must have eindimensional Array, as given by transpose working on a 2D 1 column Array
300 Let strRws = Join(Application.Transpose((Evaluate("row(A1:E10)"))), " ")
310 Let strRws = Join(Application.Transpose((arr_2D1row())), " ") ' Join ( Transpose ( { 1; 2; 3; 4; 5; 6; 7; 8; 9; 10} ) ) = Join ( { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10} )
320
330 'Final required row Indicies, with a missing indicie, as a string
340 Let strrwsD = Replace(strRws, " 5 ", " ", 1)
350 Let strrwsD = Replace(strRws, " " & y & " ", " ", 1)

360 'Split Final String by " " to get 1 1d "Pseudo Horizontal" Array
370 Dim rws() As String: Let rws() = VBA.Split(strrwsD, " ") ' 1 D Array
380 'Final Transposed Array for "magic neat" code line
390 Dim rwsT() As Variant: Let rwsT() = Application.Transpose(rws()) ' 2 D 1 "column" Array
400
440 'Output Array
450 Dim arrOut() As Variant
460 arrOut() = Application.Index(sn, rwsT(), clms())
470
480 Let Fu_snb = arrOut()
490 'Or
Let Fu_snb = Application.Index(sn, Application.Transpose(VBA.Split(Replace(Join(Appli cation.Transpose((Evaluate("row(A1:E10)"))), " "), " " & y & " ", " ", 1), " ")), Evaluate("column(A1:E10)"))
'Finally the "extra" named range bit:
'Let sn.Name = "snb_002"
Let Fu_snb = Application.Index(sn, Application.Transpose(VBA.Split(Replace(Join(Appli cation.Transpose((Evaluate("row(snb_002)"))), " "), " " & y & " ", " ", 1), " ")), Evaluate("column(snb_002)"))
' "Shorthand" evaluate
Let Fu_snb = Application.Index(sn, Application.Transpose(VBA.Split(Replace(Join(Appli cation.Transpose(([row(snb_002)])), " "), " " & y & " ", " ", 1), " ")), [column(snb_002)])
'Let Fu_snb = Application.Index(sn, Application.Transpose(VBA.Split(Trim(Replace(" " & Join(Evaluate("transpose(row(snb_002))")) & " ", " " & y & " ", " ")))), Evaluate("column(snb_002)"))
'or
'Let Fu_snb = Application.Index(sn, Application.Transpose(Split(Trim(Replace(" " & Join([transpose(row(snb_002))]) & " ", " " & y & " ", " ")))), [column(snb_002)])
End Function

[DocAElstein]

' To Test Function, Type some arbitrary values in range A1:E10, step through code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17








Main Test Code ( Required Function given a couple of Posts down )



' Delete One Row From A 2D Excel Range Area
' To Test Function, Type some arbitrary values in range A1:E10, step through code in F8 Debug Mode in VB Editor, and examine Worksheet, Immediate Window ( Ctrl+G when in VB Editor ), hover over variables in the VB Editor Window with mouse cursor, set watches on variables ( Highlight any occurrence of a variable in the VB Editor and Hit Shift+F9 ) , etc.. and then you should expected the required Output to be pasted out starting Top Left at cell M17

Sub Alan()
Dim sp() As Variant
'Dim DataArr() As Variant: Let DataArr() = Range("A1:E10").Value
Let sp() = FuR_Alan(Range("A1:E10"), 5)
'Let sp() = FuRSHg(Range("A1:E10"), 5)
'Let sp() = FuRSHgDotT(Range("A1:E10"), 5)
'Let sp() = FuRSHgShtHd(Range("A1:E10"), 5)
Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)).ClearContents
Let Range("M17").Resize(UBound(sp(), 1), UBound(sp(), 2)) = sp()
End Sub


_............


For no particular reason I am considering this as my Input "Area"

Using Excel 2007 32 bit

Row\Col
A
B
C
D
E
F1
0
10
20
30
40

2
2
12
22
32
42

3
4
14
24
34
44

4
6
16
26
36
46

5
8
18
28
38
48

6
10
20
30
40
50

7
12
22
32
42
52

8
14
24
34
44
54

9
16
26
36
46
56

10
18
28
38
48
58

11






Sheet: NPueyoGyanArraySlicing



_.......

Expected Output shown in next Post

[DocAElstein]

In support of these Forum Threads

https://www.excelforum.com/development-testing-forum/1149000-back-up-thread-no-reply-needed-find-and-replace-values-in-all-excel-files-of-directory.html#post4440512
https://excel.tips.net/T008233_Finding_the_Path_to_the_Desktop.html
http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10420&viewfull=1#post10420
http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10421&viewfull=1#post10421




Original Post was the eigth Post after this one_.....
http://www.eileenslounge.com/viewtopic.php?f=27&t=22499&p=185272#p175068
_...... but it is no longer there currently :(

_.. Original Post: ( Post Split over several Posts in this Thread ( It was one Post originally )
-::::::................
)

Hi,
I found the code here to loop through all folders and sub Folders very interesting and revealing.
I am only a novice but have answered more Threads then I can remember doing this and almost always the method I and others use is the same one. The code here is different..

So I am mainly just adding another solution as well as discussing and comparing with the solution given here by Rudi.

I am mainly looking at applying the codes to get to the point of being able to "do stuff" with each File. For the OP "doing stuff" was to Find and Replace Values in all excel files of a main Folder, including all Files in Sub Folders. But the actual Doing stuff is rarely the difficult bit. The main work is to "get at " all Files.

What really caught my eye with this Thread is that it does this without using the, as many people find a big mystery, the process of recursion.

I thought it would be very useful to write a code where the "doing stuff " was to print out to a Spreadsheet a Full Listing of all The Folders, Sub Folders., and all files within.

So for any required " doing stuff " code you could first run the code, which asks you to select your main Folder. The Print out lets you see and check that you are "getting" at each File you want. The code can then be modified by simply replacing at those lines which print out the information, the code lines necessary to do stuff to each file and / or Folder.

_..........................................
I will present two codes, a version of Rudi's and mine which is based on the classical Recursion Way.


Here then some quick notes on the codes.
Rem 1) Just some Worksheet info. Currently the Code accesses the first tab from the left ( Usually your "Sheet1" ). Identical for both codes.
Rem 2) Identical for Both Codes. Calls up a dialogue box in which you may enter the Start Folder in which all Folders and Sub Folders of interest are in. ( There are at least 3 ways in VBA I know to get that, I just chose one of them:
http://www.mrexcel.com/forum/general-excel-discussion-other-questions/223232-set-shell-%3D-createobject-shell-application.html
( The one using an Object that has a lot to do with Window things ).
http://www.mrexcel.com/forum/general-excel-discussion-other-questions/223232-set-shell-%3D-createobject-shell-application.html
I did the above just to practice something new to me.
The Application.FileDialog(msoFileDialogFolderPicker)
Originally dine by Rudis Way is probably better. That is just a VBA Property that pulls up a dialogue box, in this case the one that lets you pick a Folder.
_................................................. ............
Rem 3) Similar for both codes.
Sets up and allows us to use the Microsoft Scripting Runtime Library, which allows us to do lots with Files and related things.

Rem 4) Positional Info variable declaration.
Variables for Positons of where I print the Folder and File Info in the Worksheet.
For that the Range Object of the Top Left of where a "Explorer" Listing should go has the Cells Property applied using the Co ordinates I determine to give the Position in the Worksheet in which to paste out the Folder or File name
For Rudis Code the Queue thing is also declared
For Rudis Code I have variables for the count of Folders in the next Folder level, and for the count of the current Folder level being looped through This is the actual stand at the time within the Queue.

Rem 5 ) Here the codes differ.
Explanations are given extensively in the code 'Comments, best viewed in the VB Code Window whilst stepping through the code in debug ( F8 ) ( Whilst if possible also looking at the Spreadsheet at the same time )
Briefely in Words.

My code. The Classic recursion Type.

The Routine at Rem 5A) is called initially from the
Sub DoStuffInFoldersInFolderRecursion()
Code. It passes to it this first time the Main Folder.
This called subroutine starts going into the next level "down" or "to the right" of Sub Folders in the given Original Main Folder.
It does stuff for Each Sub Folder and files, if any , therein. ( Using a For Next Loop typically )
After that it calls itself !!!! It takes into it the current Sub Folder.
At this point most people get confused. I think, as I am thick, and can understand the following explanation , then it may be easy for most people to understand

The thing that is often missing at this point is knowing what VBA actually does when this happens. Quite simply it makes a NEW Copy of the Routine, completely independent of the Original Routine calling it. And it starts running that. The original Routine is "frozen" by VBA. And VBA stores somewhere( typically referred to as in a "Stack Row" or "Stack" ) all the variable values used in the Calling Routine and "freezes" them at their current values as well.

In the New copy all variable are new and independent of those in the Original. Unfortunately you never think you see this new Copy, but you do. If you step through such a recursion code, when it "looks" like it springs back to the original when the Code calls itself, you are actually seeing at that point the Copy.

So you see, if you have a couple of Folders, and the first has a Sub Folder in it then the following happens:
You do stuff in the First Folder. Then that Routine "freezes" as it calls itself. The current Sub Folder is taken into the "Copy" Routine. The "Copy" Routine then Does the same for the all Sub Folders now in the current Sub Folder. Important is that the Code line which calls itself is within the main For Next. So if there are no more Sub Folders, the Copy Routine will end. This occurs in our example here after the one Sub Folder. Effectively the "Copy" Routine then "dies" The original Routine then Unfreezes. So the next of our two Folders is gone through.

The only difficulty I had in writing the particular Recursion code is that I wanted to show each Folder "level" down the Folder Chain at each column going "down" or "to the right" as typically seen in a classic Explorer Window. The problem is how do I know which "Copy" Routine I am in. Every successive Copy will relate to a run in a the next "down" or "to the right. I cannot simply add a progressively increasing count, as in the recursion Code I will be going "back and forth" depending on if and how many Sub folders there are. I need a way to know at which "level" of Sub Folders I am in when in any progression back and forth.
I do that as follows. I mention it here as it does demonstrate clearly again how recursion works.
Inside the Routine towards the start is a variable,
CopyNumber.
This will be a unique variable for each "Copy" Routine. Every time the Routine is called a number is taken in at the value inside a variable in the signature line
CopyNumberFroNxtLvl
For the very first call it is set to 1 in a variable whose value is taken in at its value, as a value, in the Signature line
Within the Routine this value is given to
CopyNumber.
Only
If CopyNumber = 0
That is to say if
CopyNumber
Had never been given a number
When the function calls itself to takes in by value at the value iif using the value of
CopyNumber + 1
( Call LoopThroughEachFolderAndItsFile(myFldrs, celTL, rCnt, CopyNumber + 1) )

This has the effect that when you go to the "next down" or "next level to the right" only the first time will
CopyNumber
Be assigned, and its value will take an incremented number giving an indication of you "level"

This value is frozen when you go "further down" in the next "Copy Routine" . But When you come back up, it "thaws out" and is used within so that my line which prints out information will be in the correct "column" which is an indication in my final Output of the "level" of my folder ( and possibly Files within )

(celTL.Cells(rCnt, 1).Value = myFldrs.Path: celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = myFldrs.Name )

( celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = oFile.Name )

[DocAElstein]

_................................................. .........

Rudi's code from Rem 5R)

This works differently in a way I have never seen before. There is no need to call a "recursion Routine"

Initially The main Folder is "put" into a "Queue" ( at the " back " of it )
https://msdn.microsoft.com/en-us/library/aa227541(v=vs.60).aspx
https://msdn.microsoft.com/de-de/library/yb7y698k(v=vs.90).aspx
( I expect in the "Queue" is just holding the Pointer to the actual Folder Object
The code the does a similar For Next as in my Code. One major difference is that the first thing it does is at each Folder is to go through every Sub Folder therein and "Put" it at the "back" of the queue. It takes the current folder being "looked" at "out" of the Queue from the "front".

It effectively then "stacks up all" the Folders in the next level down. Eventually after it goes through every Folder in the current level it will reach the point where it starts on the next level. So effectively it does not go "back and forth" like mine does. Rather it has "looking up" or "back from the front" first all the first level Folders, then all the next level Folders , then all the next, and so on.
If you look at the difference in the output that I get from mine and Rudi's code, you will soon see the corresponding difference.

Again the tricky bit for me was to get a Variable to indicate the "level" or "column to the left".

What I do in this case is count every time a Sub Folder is put in the back of the Queue.
NxtLvlCnt
This will finally give an indication of the Number of Sub folders at the next level.
I have second count variable
CurrentLvlCnt
Which is originally set to the last level count ( set initially to one for the original main folder ), which is successively decreased each time a Folder is "taken out" of the queue. When it reaches zero it is an indication that we have reached the next series of Next level Sub Folders. When that occurs it is given the value of the next level Count, and the next level Cont is then reset to Zero.

_................................................. .......

For both code I finally added a bit of Error handling. I did this as when I tested with many real files , I often had an error if , for example the "doing stuff" involved opening a file. If this happens you are told what error occurred and to which file, then you go on to the next. ( I assume that errors do not occur in the original code that just Prints out the "explorer type" Listing. If it did I expect the output could go a bit out if step !! ) )

_...............................................

So I give here some typical output from a run of both codes. To make it a bit easier I include the example set of Folders I used. ( I hope they all come up. By me only a few Folders come up, although the are "indicted as all there " ? ? )
https://app.box.com/s/onj6ntvwkxbo1088x7e0tca2gst45hnq
( Edit : Here is another Folder to try https://app.box.com/s/9e6xnb65fijjhl7bk0q6gzzriihkzibw )


words I have a main
EileensFldr

That has three sub folders in it. Therein are files and further sub Folders and files etc…. as seen in the listing the Code gives.

Initially the code is set to run from a file in the same directory as folder EileensFldr

[DocAElstein]

Output Given from my code

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F

1H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldrEileensFldr


2


3H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldr\Fldr1_1Fldr1_1


4File1_1a.xlsx


5File1_1b.xlsx


6


7H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldr\Fldr1_2Fldr1_2


8File1_2a.xlsx


9File1_2b.xlsx


10File1_2c.xlsx


11


12H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1Fldr1_2_1


13File1_2_1a.xlsx


14File1_2_1b.xlsx


15


16H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_1Fldr1_2_1_ 1


17File1_2_1_1a.xlsx


18


19H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2Fldr1_2_1_ 2


20File1_2_1_2a.xlsx


21File1_2_1_2b.xlsx


22


23H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3Fldr1_3


24


25H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1Fldr1_3_1


26


27H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1\Flsr1_3_1_1Flsr1_3_1_ 1


28


29H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1\Flsr1_3_1_1\Fldr1_3_1 _1_1Fldr1_3_1_1_1
EFFldr

[DocAElstein]

Correspondoing Output given by Rudi's code

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F

1H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldrEileensFldr


2


3H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldr\Fldr1_1Fldr1_1


4File1_1a.xlsx


5File1_1b.xlsx


6


7H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\Ei leensFldr\Fldr1_2Fldr1_2


8File1_2a.xlsx


9File1_2b.xlsx


10File1_2c.xlsx


11


12H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3Fldr1_3


13


14H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1Fldr1_2_1


15File1_2_1a.xlsx


16File1_2_1b.xlsx


17


18H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1Fldr1_3_1


19


20H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_1Fldr1_2_1_ 1


21File1_2_1_1a.xlsx


22


23H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2Fldr1_2_1_ 2


24File1_2_1_2a.xlsx


25File1_2_1_2b.xlsx


26


27H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1\Flsr1_3_1_1Flsr1_3_1_ 1


28


29H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E ileensFldr\Fldr1_3\Fldr1_3_1\Flsr1_3_1_1\Fldr1_3_1 _1_1Fldr1_3_1_1_1
EFFldr

[DocAElstein]

Codes:
Rudi's Code
Sub ReplaceInAllSubFoldersRudisQing()

'' http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html





' Rudi http://www.eileenslounge.com/viewtopic.php?f=27&t=22499
Sub ReplaceInAllSubFoldersQing()
Rem 1Q) Some Worksheets and General Variables Info
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets.Item(1) 'Worksheets("RudyMSRQueue") 'CHANGE TO SUIT YOUR WORKSHEET
Dim strDefpath As String: Let strDefpath = ThisWorkbook.Path ' Any Path to Folder to test this code! here we simply use the Path where the File with this code in is
Dim strDefFldr As String: Let strDefFldr = "EileensFldr" 'Just for an initial suggestion
Rem 2Q) Get Folder Info ( Using VBA Application.FileDialog(msoFileDialogFolderPicker) Property )
Dim strWB As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Folder Select "
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
Let strWB = .SelectedItems(1) & "\"
End With

Rem 3Q) Microsoft Scripting Runtime Library
'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 in the Tools > References menu of VBE.
Set FSO = New Scripting.FileSystemObject

Rem 4Q)'Some variables for Positon of Things
Dim rCnt As Long, clmLvl As Long: Let clmLvl = 1: Let rCnt = -1 'rowCount is genaraly increase for a new entry, Column "level" is intended to give an indication of how far down ( to he right ) you are in the Folder chain. Ste to 1 for the first mainn Initial Folder.
Dim CurrentLvlCnt As Long: CurrentLvlCnt = 1 'Count of the Number of Folders in the Folder level currently beig run through.
Dim NxtLvlCnt As Long 'Count of the Number of Folders in the next level
Dim queue As Collection
Set queue = New Collection
queue.Add FSO.GetFolder(strWB) 'Main Folder Put at position 1 of Queue'''''
Dim celTL As Range: Set celTL = ws.Range("A1") 'Top left of where Listing should go
'Application.ScreenUpdating = False

Rem 5Q) Main loop. Do While Queue is not Empty effectivelly goes through all Folders
Dim oFile As Variant, oFolder As Variant, oSubfolder As Variant ' Can also be variant Types or Objects. - Must be for Late Binding
Do While queue.Count > 0 'Main Loop. Does as many times as there are things ( Folders here ) stacked in the Queue========
Set oFolder = queue(1) 'Next Folder .... effectively
queue.Remove 1 'de-queue'......"taken" from start of Queue. ( Actually it is assigned to a variable, then removed from the Queue, which probably just has the Pointer to it.
CurrentLvlCnt = CurrentLvlCnt - 1 'de-the count for numbers in in this current Folder level
''''''''Doing Stuff For the Folder
rCnt = rCnt + 2 'Move on a line and a spare Line for every Folder Entry
celTL.Cells(rCnt, 1).Value = oFolder.Path: celTL.Cells(rCnt, clmLvl).Offset(0, 1).Value = oFolder.Name 'Cell poroperty of Top Left Cell Range Object uset to position output.
''''''''End Doing Stuff for each Folder
'5Qa) Add any Sub Folders from current Folder at end of queue
For Each oSubfolder In oFolder.SubFolders 'For as many ( if any ) Sub Folders In the Current Folder
queue.Add oSubfolder 'en-queue.. add the Sub Folder on at the end of the Queue
NxtLvlCnt = NxtLvlCnt + 1 'en-the count of the Folders in the next Level..Increase our count of the Folders in the Next folder level
Next oSubfolder
'5b) Doing Stuff for every file in current folder
For Each oFile In oFolder.Files
'''''''Doing Stuff for Each File here
If InStr(1, oFile.Name, ".xls") > 0 Then 'Option to select only if .xls ( or .xlsx or .xlsm ) type files
rCnt = rCnt + 1
celTL.Cells(rCnt, clmLvl).Offset(0, 1).Value = oFile.Name
On Error GoTo ErrHdlr 'In case problem opening file for example
'Set wbk = Workbooks.Open(oFile)
'wbk.Close SaveChanges:=True
Else: End If
'''''''End Doing Stuff 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
'5Qc) should we have reached the end of the current level of Folders, we reset the level Column for output, and make the new Current Folders in Folder level Count equel to the next one, as we go ion now to Folders from the next level.
If CurrentLvlCnt = 0 Then
clmLvl = clmLvl + 1 'Set column position 1 to the left "down" the Folder Level Chain.
Let CurrentLvlCnt = NxtLvlCnt 'So the current Folder Level count of Folders becomes that last counted.
NxtLvlCnt = 0 'Next level of Folders currently are not in the Queue. This will be re counted for the next Folders as Sub Folders are added to the back of the Queue
Else
End If

Loop 'queue.Count > 0 main loop for all Folders=========================================== ==========================
Application.ScreenUpdating = True
MsgBox "All Excel Files processed", vbInformation
ws.Columns("A:H").AutoFit
Exit Sub 'Normal End for no Erriors
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

[DocAElstein]

My codes
Main Code
Sub DoStuffInFoldersInFolderRecursion()
And called Routine
Sub LoopThroughEachFolderAndItsFile(



Option Explicit
'
'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
Sub DoStuffInFoldersInFolderRecursion() 'Main Procedure to call the Function LoopThroughEachFolder(objFolder)
Rem 1A) Some Worksheets and General Variables Info
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets.Item(1) 'Worksheets("RudyMSRQueue") 'CHANGE TO SUIT YOUR WORKSHEET
Dim strDefPath As String: Let strDefPath = ThisWorkbook.Path ' Any Path to Folder to test this code! here we simply use the Path where the File with this code in is
Dim strDefFldr As String: Let strDefFldr = "EileensFldr" 'Just for an initial suggestion
Rem 2A) Get Folder Info ( Using Library Shell32 ( C:\WINDOWS\system32\SHELL32.dll ) Microsoft Shell Controls And Automation )
Dim ShellApp As Shell32.Shell ' The next two lines are the equivalent "Early Binding pair"
Set ShellApp = New Shell32.Shell ''You will need to do select form VB Editor options .. Extras...then scroll down to Microsoft Shell Controls And Automation ... and add a check
Dim objWB As Object, strWB As String 'The .BrowseForFolder Method appears either return a string of the Folder name you choose, or an object which is that chosen Folder, depending on how you declare the variable to put the retuned "thing" in
Set objWB = ShellApp.BrowseForFolder(0, "Please choose a folder", 0, "" & strDefPath & "\" & strDefFldr & "") 'An Object of Folder type returned
Let strWB = CStr(objWB) ' ! Cstr seems not to be necerssary

Rem 3A )
'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 Folder 'An Object from myFolder, can be an declared as Object also
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, CopyNumber As Long: Let rCnt = 1: Let CopyNumber = 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
Dim celTL As Range: Set celTL = ws.Range("A1") 'Top left of where Licting should go
celTL.Value = myFolder.Path: celTL.Offset(0, 1).Value = myFolder.Name: ws.Columns("A:C").AutoFit 'First output Row
Call LoopThroughEachFolderAndItsFile(myFolder, celTL, rCnt, CopyNumber) 'Up until now we just got the initial Folder. Now we go to all sub folders then all subfolders then all subfolders.......
Application.ScreenUpdating = True
MsgBox "All Excel Files processed", vbInformation
ws.Columns("A:H").AutoFit
End Sub
Rem 5A)
Sub LoopThroughEachFolderAndItsFile(ByVal fldFldr As Folder, 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 Folder ''This is used continuously as the "steering" thing, that is to say each Sub Folder in Folder loops, in loops, in loops......etc
Dim CopyNumber As Long 'equivalent to clmLvl in Rudis Q code
If CopyNumber = 0 Then CopyNumber = CopyNumberFroNxtLvl 'If this variable in this Copy of the Routine has not been set then we have reached the next Copy for the First time, so set the variable so we have an indication ( number to the right or "down" Folder Chain
'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
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
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 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

'
'
'' http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html

[DocAElstein]

My codes ( again in color!! )
Main Code
Sub DoStuffInFoldersInFolderRecursion()
And called Routine
Sub LoopThroughEachFolderAndItsFile(



Option Explicit
'
'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 DoStuffInFoldersInFolderRecursion() 'Main Procedure to call the Function LoopThroughEachFolderAndItsFile(
Rem 1A) Some Worksheets and General Variables Info
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets.Item(1) 'Worksheets("EFFldr") 'CHANGE TO SUIT YOUR WORKSHEET
Rem 2A) Get Folder Info ( Using VBA Application.FileDialog(msoFileDialogFolderPicker) Property )
Dim strWB As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Folder Select "
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
Let strWB = .SelectedItems(1) & "\"
End With

Rem 3A )
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, CopyNumber As Long: Let rCnt = 1: Let CopyNumber = 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
Dim celTL As Range: Set celTL = ws.Range("A1") 'Top left of where Licting should go
celTL.Value = myFolder.Path: celTL.Offset(0, 1).Value = myFolder.Name: ws.Columns("A:C").AutoFit 'First output Row
Call LoopThroughEachFolderAndItsFile(myFolder, celTL, rCnt, CopyNumber) 'Up until now we just got the initial Folder. Now we go to all sub folders then all subfolders then all subfolders.......
Application.ScreenUpdating = True
MsgBox "All Excel Files processed", vbInformation
ws.Columns("A:H").AutoFit
End Sub
Rem 5A)
Sub LoopThroughEachFolderAndItsFile(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
If CopyNumber = 0 Then CopyNumber = CopyNumberFroNxtLvl 'If this variable in this Copy of the Routine has not been set then we have reached the next Copy for the First time, so set the variable so we have an indication ( number to the right or "down" Folder Chain
'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
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
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

[DocAElstein]

Here is another Folder to try
https://app.box.com/s/9e6xnb65fijjhl7bk0q6gzzriihkzibw

Results from that for my Code:

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F

1H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1EFldr1_1


2


3H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1\EFldr1_1_1EFldr1_1_1


4File1_1_1a.xlsx


5File1_1_2b.xlsx


6


7H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1\EFldr1_1_2EFldr1_1_2


8File1_1_2a.xlsx


9File1_1_2b.xlsx


10


11H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1Fldr1_1_2_1


12File1_1_2_1a.xlsx


13File1_1_2_1b.xlsx


14


15H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1\Fldr1_1_2_1_1Fldr1_ 1_2_1_1


16File1_1_2_1_1a.xlsx


17


18H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1\Fldr1_1_2_1_2Fldr1_ 1_2_1_2


19File1_1_2_1_2a.xlsx


20File1_1_2_1_2b.xlsx


21


22H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3EFldr1_1_3


23


24H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3\Fldr1_1_3_1Fldr1_1_3_1


25


26H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3\Fldr1_1_3_1\Flsr1_1_3_1_1Flsr1_ 1_3_1_1


27File1_1_3_1_1a.xlsx


28
EFFldr

[DocAElstein]

Results using this main Folder
https://app.box.com/s/9e6xnb65fijjhl7bk0q6gzzriihkzibw
using Rudi's code:


Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F

1H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1EFldr1_1


2


3H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1\EFldr1_1_1EFldr1_1_1


4File1_1_1a.xlsx


5File1_1_2b.xlsx


6


7H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\EF ldr1_1\EFldr1_1_2EFldr1_1_2


8File1_1_2a.xlsx


9File1_1_2b.xlsx


10


11H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3EFldr1_1_3


12


13H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1Fldr1_1_2_1


14File1_1_2_1a.xlsx


15File1_1_2_1b.xlsx


16


17H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3\Fldr1_1_3_1Fldr1_1_3_1


18


19H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1\Fldr1_1_2_1_1Fldr1_ 1_2_1_1


20File1_1_2_1_1a.xlsx


21


22H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_2\Fldr1_1_2_1\Fldr1_1_2_1_2Fldr1_ 1_2_1_2


23File1_1_2_1_2a.xlsx


24File1_1_2_1_2b.xlsx


25


26H:\Excel0202015Jan2016\ExcelForum\wbSheetMaker\E Fldr1_1\EFldr1_1_3\Fldr1_1_3_1\Flsr1_1_3_1_1Flsr1_ 1_3_1_1


27File1_1_3_1_1a.xlsx


28
EFFldr

[DocAElstein]

Second Code for nelson
Post 9
http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10070#post10070





[Code]Sub IJAdjustKAddTotalAllWorksheet() ' http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10060#post10060
Rem 1) Workbooks Info.
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.)
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
Dim wsStear As Worksheet ' Used for each Worksheet counting Tabs from left from 1 To Total
Rem 2) varables for some totals ;)
Const TDays As Long = 30 'Total days just taken as 30 ' 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. )
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..
Rem 3) Loop through worksheets and give some Totals
Dim Cnt As Long ' Loop Bound variable count for going through all worksheets
'3a) main Loop start============================================= ========
For Cnt = 1 To Wb.Worksheets.Count ' The Worksheets collection Object Property returns the number of worksheet items in the Workbook
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
Dim lr As Long ' Used for last row number in column E
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.
Dim FstDtaCel As Range: Set FstDtaCel = wsStear.Range("A1") ' Worksheets Range(" ") Property used to return Range object of first cell in second row
'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
Dim arrInNorm() As Variant, arrInOver() As Variant ' In the next lines the .Value2 or .value 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
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 ??
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
Dim arrTotHrs() As Variant ' ,' ## ' arrDteClr() As Variant
Let arrTotHrs() = FstDtaCel.Offset(0, 7).Resize(lr, 1).Value [color=darkgreen]' 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

[DocAElstein]

In support of this Thread Question
https://excel.tips.net/T008233_Finding_the_Path_to_the_Desktop.html
https://excel.tips.net/T008233_Finding_the_Path_to_the_Desktop.html




…………………… I tried this one
sPath = Environ("USERPROFILE") & "\Desktop"

It didn't work for me, because I had moved my desktop to another location.
Is there a way to find the 'actual' placement?.......................................




[FONT=Arial][size=3]

[color=#417394]Demo Example

Download both files. Put both in the same folder. ( Unzip the zipped file

[DocAElstein]

_____ Workbook: wbCodes.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1


2


3F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldrEileensFldr


4


5F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldr\Fldr1_1Fldr1_1


6File1_1a.xlsx


7File1_1b.xlsx


8


9F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldr\Fldr1_1\Fldr1_1_1Fldr1_1_1


10


11F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2Fldr1_2


12File1_2a.xlsx


13File1_2b.xlsx


14File1_2c.xlsx


15


16F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1Fldr1_2_1


17File1_2_1a.xlsx


18File1_2_1b.xlsx


19


20F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_1Fldr 1_2_1_1


21File1_2_1_1a.xlsx


22


23F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2Fldr 1_2_1_2


24File1_2_1_2a.xlsx


25File1_2_1_2b.xlsx


26


27F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2\Des ktopDesktop


28
Worksheet: Sheet1

[DocAElstein]

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

1


2


3F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldr


4


5F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldr\Fldr1_1


6


7


8


9F:\Excel0202015Jan2016\OffenFragensForums\AllenWy att\EileensFldr\Fldr1_1\Fldr1_1_1


10


11F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2


12


13


14


15


16F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1


17


18


19


20F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_1


21


22


23F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2


24


25


26


27F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\EileensFldr\Fldr1_2\Fldr1_2_1\Fldr1_2_1_2\Des ktop


28
Worksheet: Sheet1

[DocAElstein]

ASHDKHDHDKHD

[DocAElstein]

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



<b>Excel 2007 32 bit</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /><col /><col /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>D</th><th>E</th><th>F</th><th>G</th><th>H</th><th>I</th><th>J</th><th>K</th><th>L</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">21.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">22.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;background-color: #FFFF00;;">23.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">15:00</td><td style="text-align: right;;">8:00</td><td style="text-align: right;;"></td><td style="text-align: right;;">8:00</td><td style="text-align: right;;"></td><td style=";">H</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">24.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">25.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">26.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">27.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">17:00</td><td style="text-align: right;;">10:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">1:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">28.Dec.16</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style="text-align: right;;"></td><td style="font-weight: bold;text-align: right;;">29.Dec.16</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">ABSENT</td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">10</td><td style="text-align: right;;"></td><td style="font-weight: bold;text-align: right;background-color: #FFFF00;;">30.Dec.16</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">ABSENT</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">11</td><td style="text-align: right;;"></td><td style="font-weight: bold;text-align: right;;">31.Dec.16</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">ABSENT</td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">12</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">1.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">13</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">2.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">14</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">3.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">15</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">4.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">16</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">5.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">17</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;background-color: #FFFF00;;">6.Jan.17</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">H</td></tr><tr ><td style="color: #161120;text-align: center;">18</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">7.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">19</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">8.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">20</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">9.Jan.17</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">ABSENT</td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">21</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">10.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">22</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">11.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">23</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">12.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">24</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;background-color: #FFFF00;;">13.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;"></td><td style="text-align: right;;">10:00</td><td style="text-align: right;;"></td><td style=";">H</td></tr><tr ><td style="color: #161120;text-align: center;">25</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">14.Jan.17</td><td style="text-align: right;;">7:30</td><td style="text-align: right;;">17:30</td><td style="text-align: right;;">10:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">1:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">26</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">15.Jan.17</td><td style="text-align: right;;">7:30</td><td style="text-align: right;;">17:30</td><td style="text-align: right;;">10:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">1:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">27</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">16.Jan.17</td><td style="text-align: right;;">7:30</td><td style="text-align: right;;">17:30</td><td style="text-align: right;;">10:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">1:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">28</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">17.Jan.17</td><td style="text-align: right;;">7:30</td><td style="text-align: right;;">17:30</td><td style="text-align: right;;">10:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">1:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">29</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;;">18.Jan.17</td><td style="text-align: right;;">7:00</td><td style="text-align: right;;">18:00</td><td style="text-align: right;;">11:00</td><td style="text-align: right;;">9:00</td><td style="text-align: right;;">2:00</td><td style="text-align: right;;"></td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">30</td><td style="text-align: right;;"></td><td style="font-weight: bold;text-align: right;;">19.Jan.17</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">ABSENT</td><td style=";">N</td></tr><tr ><td style="color: #161120;text-align: center;">31</td><td style=";">TEAM LEADER</td><td style="font-weight: bold;text-align: right;background-color: #FFFF00;;">20.Jan.17</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">H</td></tr></tbody></table><p style="width:9em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">After121</p><br /><br />

[DocAElstein]

Totals output for last post ( HTML )

<b>Excel 2007 32 bit</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /><col /><col /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>B</th><th>C</th><th>D</th><th>E</th><th>F</th><th>G</th><th>H</th><th>I</th><th>J</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">34</td><td style="font-weight: bold;background-color: #FFFFFF;;">TOTAL NO. OF DAYS &nbsp;-----&gt;</td><td style="font-weight: bold;background-color: #FFFFFF;;">25</td><td style="font-weight: bold;;"></td><td style="text-align: center;;"></td><td style="font-weight: bold;text-align: right;;">Normal Overtime &nbsp;-----&gt;</td><td style="font-weight: bold;;">39</td><td style="text-align: right;;"></td><td style="font-weight: bold;text-align: right;;">Holiday Overtime &nbsp;-----&gt;</td><td style="font-weight: bold;;">18</td></tr></tbody></table><p style="width:9em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">After121</p><br /><br /><table width="85%" cellpadding="2.5px" rules="all" style=";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: #FFFFFF" ><tr><td style="padding:6px" ><b>Worksheet Formulas</b><table cellpadding="2.5px" width="100%" rules="all" style="border: 1px solid;text-align:center;background-color: #FFFFFF;border-collapse: collapse; border-color: #A6AAB6"><thead><tr style=" background-color: #E0E0F0;color: #161120"><th width="10px">Cell</th><th style="text-align:left;padding-left:5px;">Formula</th></tr></thead><tbody><tr><th width="10px" style=" background-color: #E0E0F0;color: #161120">C34</th><td style="text-align:left">=30-COUNTIF(<font color="#0000FF">K1:K31,"ABSENT"</font>)</td></tr><tr><th width="10px" style=" background-color: #E0E0F0;color: #161120">G34</th><td style="text-align:left">=SUMIF(<font color="#0000FF">L1:L31,"N",J1:J31</font>)*24</td></tr><tr><th width="10px" style=" background-color: #E0E0F0;color: #161120">J34</th><td style="text-align:left">=SUMIF(<font color="#0000FF">L1:L31,"H",J1:J31</font>)*24</td></tr></tbody></table></td></tr></table><br />

[DocAElstein]

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/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?


'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_AllWorkshe etsCode4() '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

[DocAElstein]

Sub IJAdjust_LAdd_AbsentKAdd_TotalsFormulas_AllWorkshe etsCode4() Part 2

For Post http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10094#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




'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

[DocAElstein]

Codes required for contribution to , and to be referenced from, this Thread: http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA

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


'====================================
' 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


'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 ) )

[DocAElstein]

Dumping Logs for support of this Thread Post:
http://www.excelfox.com/forum/showthread.php/2227-VBA-Input-Pop-up-Boxes-Application-InputBox-Method-versus-VBA-InputBox-Function?p=10476#post10476

Test Function used to produce the Log below


'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





---------------------------
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:


' 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


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

[DocAElstein]

Per PM request: One full working example of above 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()


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


'_-=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

[DocAElstein]

Code solution for this Thread
http://www.excelfox.com/forum/showthread.php/2229-complete-page-numbers
https://www.excelforum.com/excel-programming-vba-macros/1219601-fill-out-shortened-numbers.html





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

[DocAElstein]

Code for this Thread:
http://www.excelfox.com/forum/showthread.php/2232-Excel-VBA-comma-point-thousand-decimal-separator-number-problem?p=10503#post10503
http://www.excelfox.com/forum/forumdisplay.php/13-Excel-Tips-and-Tricks


Function CStrSepDbl


'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

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

[DocAElstein]

Further notes in support of answer to this Thread:
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once?p=10518#post10518



Microsoft Outlook.
WTF is that and HTF do you do anything with it, and WTF is it supposed to do.
I didn't know. And still don't......
The internet is full of stuff on this, but there is no clear explanation of what it is or what it should do or how you do anything with it.

But I had a go
Microsoft Outlook: what is that ( using manually )
You would normally get the software to run on its own ( visible as it were ) in a similar way to which you might get Word or Excel to start, for example
Find it single click on it:
FindOutlook Start AllProgrammes Microsoft MicrosoftOutlook.JPG : https://imgur.com/LaGs6HA
FindOutlook Start TypeInSearchBox Outlook.JPG : https://imgur.com/IbFOSHz
Make a Desktop icon from a Copy/ paste and double click on it :
MicrosoftOutlook Make a desktop Icon to double click on.JPG : https://imgur.com/ZNNPmOI
The first time you try to open it with a click or two, a set up starts.
Outlook2003Start.JPG https://imgur.com/tSQDoTe
The main use of the Outlook software is to do Email stuff, so usually you will have at least one Email account “registered in it” You can do this at the set up or later.
I had a go,
the start was OK:
Outlook2003Start.JPG https://imgur.com/R71pKfy
Outlook2003Start2.JPG https://imgur.com/XUFMpEm
These following steps took me a few hours of Emails, Internet surfing and annoying Telephone calls to my Internet provider before I
_ chose IMAP here : Outlook2003Start3ServerType.JPG : https://imgur.com/Jmnd6Vb
and
_ got the two required things to put in the 2 server information bars, and other stuff to fill in this : Outlook2003Start4ServerConfiguration.JPG : https://imgur.com/NXNAt9J

Von: "Doc.AElstein@t-online.de" <Doc.AElstein@t-online.de>
An: "elston, alan" <Doc.AElstein@t-online.de>
Pop3
* Serveradresse Port* Sicherheit
Posteingang securepop.t-online.de 995 SSL / TLS
Postausgang securesmtp.t-online.de 465 SSL
*
E-Mails über IMAP4 abrufen
* Serveradresse Port* Sicherheit
Posteingang secureimap.t-online.de 993 SSL
Postausgang securesmtp.t-online.de 465 SSL

From: "Doc.AElstein@t-online.de" <Doc.AElstein@t-online.de>
To: "elston, alan" <Doc.AElstein@t-online.de>
pop3
Server address Port Security
Inbox securepop.t-online.de 995 SSL / TLS
Outbox securesmtp.t-online.de 465 SSL

Retrieve emails via IMAP4
Server address Port Security
Inbox secureimap.t-online.de 993 SSL
Outbox securesmtp.t-online.de 465 SSL

Outlook2003Start4ServerConfiguration.JPG : https://imgur.com/NXNAt9J
MyTelekomNameUsernamePassword.JPG : https://imgur.com/K6qZgsE
TelekomInternetConfiguration.JPG : https://imgur.com/Z3XcsJu



Then I hit Finish:
Outlook2003Start5Fertig.JPG : https://imgur.com/wIMvqBb ´
I get an error in the left Pane atz that point or later as well sometimes :
Outlook2003Start6LeftpaneErrror.JPG : https://imgur.com/35XLQv6

could not connect to the server secureimap t online.JPG : https://imgur.com/UqEZtQe
Fehler (0x800CCC0E) beim Ausführen der Aufgabe "Suchen nach neuen Nachrichten in den abonnierten Ordnern auf secureimap.t-online.de.": "Der Download des Ordners "(null)" von Konto "secureimap.t-online.de" vom IMAP-Mailserver ist fehlgeschlagen. Fehler: Die Verbindung zum Server konnte nicht hergestellt werden. Falls dieser Fehler weiterhin auftritt, wenden Sie sich an den Serveradministrator oder den Internetdienstanbieter."

Fehler (0x800CCC0E) beim Ausführen der Aufgabe "secureimap.t-online.de: Posteingang - Auf neue E-Mail überprüfen.": "Der Download des Ordners "Posteingang" von Konto "secureimap.t-online.de" vom IMAP-Mailserver ist fehlgeschlagen. Fehler: Die Verbindung zum Server konnte nicht hergestellt werden. Falls dieser Fehler weiterhin auftritt, wenden Sie sich an den Serveradministrator oder den Internetdienstanbieter."





Error (0x800CCC0E) while performing the task "Search for new messages in the subscribed folders on secureimap.t-online.de.": "Downloading the folder" (null) "from account" secureimap.t-online.de "from IMAP mail server failed Error: Unable to connect to server If this error persists, contact your server administrator or ISP. "

Error (0x800CCC0E) when executing the task "secureimap.t-online.de: Inbox - Check for new e-mail.": "The download of the folder" Inbox "of account" secureimap.t-online.de "from IMAP- Mail server failed Error: Unable to connect to server If this error persists, contact your server administrator or ISP. "




Every time I open Microsoft Outlook after that I get a pop up : could not connect to the server secureimap t online.JPG : https://imgur.com/UqEZtQe

Es Konnte keine Verbindung zum Server hergestellt werden. secureimap.t-online.de befindet sich jetzt im Offlinemodus

It could not connect to the server. secureimap.t-online.de is now in offline mode

So I am still none the wiser, but It is worth doing all that anyway as you may need some of that information later in one or more of the ways to send an Email using VBA.

[DocAElstein]

_1 ) Way 1) Use the CDO (Collaboration Data Objects ) object library available in VBA
Main Code , Sub PetrasDailyProWay1_COM_Way() ,
and
Function Code for solution to this Thread and Post
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once?p=10518#post10518






Option Explicit ' Daily Diet plan, Sending of Notes and an Excel File
Sub PetrasDailyProWay1_COM_Way() ' Allow access to deep down cods wollops from Microsoft to collaborating in particular in the form of messaging. An available library of ddl library functions and associated things is available on request, the Microsoft CDO for Windows 2000. We require some of these ' CDO is an object library that exposes the interfaces of the Messaging Application Programming Interface (MAPI). API: interfaces that are fairly easy to use from a fairly higher level from within a higher level programming language. In other words this allows you to get at and use some of the stuff to do with the COM OLE Bollocks from within a programming language such as VBA API is often referring loosely to do with using certain shipped with Windows software in Folders often having the extension dll. This extension , or rather the dll stands for direct link libraries. These are special sort of executable files of functions shared by many other (Windows based usually) software’s.
' Rem1 The deep down fundamental stuff , which includes stuff been there the longest goes by the name of Component Object Model. Stuff which is often, but not always, later stuff, or at a slightly higher level of the computer workings, or slightly more to a specific application ( an actual running "runtime" usage / at an instance in time , "instance of" ) orientated goes to the name of Object Linking and Embedding. At this lower level, there are protocols for communicating between things, and things relate are grouped into the to Office application available Library, CDO. An important object there goes by the name of Message.
'Rem 1) Library made available ====================#
With CreateObject("CDO.Message") ' Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
'Rem 2 ' Intraction protocols are given requird infomation and then set
'2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof; http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection. https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
.Configuration(LCD_CW & "smtpusessl") = True ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details. ' SSL protocol has always been used to encrypt and secure transmitted data
.Configuration(LCD_CW & "smtpauthenticate") = 1 ' ... possibly this also needed .. When you also get the Authentication Required Error you can add this three lines.
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "securesmtp.t-online.de" '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de" 465 SMTP is just used to mean the common stuff..... Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
' The mechanism to use to send messages.
.Configuration(LCD_CW & "sendusing") = 2 ' Based on the LCD_OLE Data Base of type DBTYPE_I4
.Configuration(LCD_CW & "smtpserverport") = 25 ' 465or25fort-online ' 465 'or 587 'or 25 ' The port of type somehow refered to by the last line
'
.Configuration(LCD_CW & "sendusername") = "excelvbaexp@gmail.com" ' "Doc.AElstein@t-online.de" ' .... "server rejected your response". AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
.Configuration(LCD_CW & "sendpassword") = "Bollocks" ' "Bollox"
' Optional - How long to try ( End remote SMTP server configuration section )
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 ' Or there Abouts ;) :)
' Intraction protocol is Set/ Updated
.Configuration.Fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially .. .Configuration.Load -1 ' CDO Source Defaults
'End With ' -------------------* my Created LCDCW Library ( Linking Configuration Data Cods Wollups) which are used and items configured for the Exchange at Microsoft's protocol therof;
'2b) ' Data to be sent
'.To = "Doc.AElstein@t-online.de"
.To = "excelvbaexp@gmail.com"
.CC = ""
.BCC = ""
.from = """Alan"" <Doc.AElstein@t-online.de>"
.Subject = "Bollox"
'.TextBody = "Hi" & vbNewLine & vbNewLine & "Please find the Excel workbook attached."
.HTMLBody = MyLengthyStreaming
.AddAttachment "G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan 2016\Übersicht aktuell.xlsx" ' ' Full File path and name. File must be closed
Rem 3 Do it
.Send
End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
End Sub
Public Function MyLengthyStreaming() As String
Rem 1 Make a long string from a Microsoft Word doc
'1(i) makes available the Library of stuff, objects, Methods etc.
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
'1(ii) makes the big File Object " Full path and file name of Word doc saved as .htm "
Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan 2016\ProMessage.htm"): Debug.Print FileObject
'1(iii) sets up the data "stream highway"
Dim Textreme As Object: Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2) ' reading only, Opens using system default https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
'1(iv) pulls in the data, in our case into a simple string variable
Let MyLengthyStreaming = Textreme.ReadAll ' Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
Textreme.Close
Set Textreme = Nothing
Set Fso = Nothing
Rem 2 possible additions to MyLengthyStreaming






Last bit of Function ( must go here in the excelfox Test Sub Forum in HTML Tags as there are HTML Tags in the final text string string and this makes a mess in normal BB code tags, because in excelfox Test Forum HTML is activated ) :


Rem 2
Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
End Function

[DocAElstein]

Function Code for solution to this Thread and Post
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once?p=10518#post10518





HTML For CDO.Message.HTMLBody in VBA Emails sending

Linked in my Binding Function, MyLenghtyString LBF_MLS
In support of this Thread:
http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once

HTM / HTML is a very typical electronic message language recognised by most software devices associated with Email and similar.
In two ways considered in this Thread , http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once?p=10512#post10512 , the main Message Text body to be sent in an Email can be supplied as a single HTML code string.

One convenient way to supply this is with a simple Word.doc file which can simply saved with a htm file extension
Word doc to htm.JPG : https://imgur.com/vhRE9CC

By opening this with a simple text editor, the actual text along with much more htm code detail can be revealed
LastBitOfProMessage htm.JPG : https://imgur.com/mT6l40I
LastBitOfProMessage htm 2.JPG : https://imgur.com/s0U8419

This is the actual text required to be given after the an Email data filling code line like:
_ .HTMLBody =

The actual file held anywhere will likely include all sorts of computery stuff in addition to that text.
We can get at just the text in several ways.
A typical way in VBA is to make use of one of a number of Object Orientated stuff held in the Visual Basic FileSystemObject Object. This is in turn part of the Bundle in the available to application programs (such as Excel VBA) Library, Microsoft Scripting Runtime

The way this works is as follows.
For a given file, a large object can be made within the Microsoft Scripting Runtime Library Class type Module like Library, ** Polymorphically speaking.
The Microsoft Scripting Runtime FileSystemObject Object GetFile method returns this object requiring only its full file path in order to “Get at it” . ( The returned object is pseudo in the streaming runtime instant direct compiling linking .Net technology held as a running link, ( indeed by assigning the object to, or using in an environment of, String will itself return that arguments string reference ) )
**:From Microsoft documentation: Visual Basic provides polymorphism through multiple ActiveX interfaces. In the Component Object Model (COM) that forms the infrastructure of the ActiveX specification, multiple interfaces allow systems of software components to evolve and break existing code.
In this sense interface is a set of related properties and methods. Much of the ActiveX specification is concerned with implementing standard interfaces to obtain system services or to provide malfunctionality to other programs.
The actual processes involved are in the meantime so messed up that it is a wonder that anything still works, and I doubt it will be long before nothing does.
The large FileObject in the Microsoft Scripting Runtime Library Class type Module like Library has information , amongst other things of neighbouring things , and as is typical in this mixed up messed up process , a short tem path or highway is made, and more often than not a “text stream object”, something like a continuous stream of data or like a highways going around in circles, and this will only be of a runtime existence, or at any rate should.. during this lifetime it can be “read”. I guess for any file of any type data within it will be recognised as such and can be handled in this simple text stream way.

The original coding goes quite a way back and does not really fit in Object Orientated Visual basic hierarchical structure of the original implementation of File I/O in Visual Basic. But it does at lest work well in getting at text stream string things which we are interested in

The available methods and the such reflect all the above…
-…So code will have a string getting section that..
1(i) makes available the Library of stuff, objects, Methods etc.
1(ii) makes the big File Object
1(iii) sets up the data “stream highway”
1(iv) pulls in the data, in our case into a simple string variable


_.____
I have decided for my requirement to use a “Function” for this, not just to house tidily the above steps, but also as I may add some additional bits from time to time too the main inner body string for my Email message, which the main function of this all is to produce.
To recap on the Function idea here ( http://www.excelfox.com/forum/showthread.php/2232-Excel-VBA-comma-point-thousand-decimal-separator-number-problem#post10503 )

In end effect I want a String. In fact in the main code in which this should be embedded has this as a variable
Pseudo, Linked in my Binding Function, ObjectLinkedEbeded Stuff
In place of an actual static linked variable_...
Dim MyLenghtyString As String
_ Let MyLenghtyString = “static linked at pseudo Compile String”

_.. I have
Function MyLenghyString(Export) As String
_ Pall MyLenghyString()_Import
_.. or Let MyLenghtyString = “direct linked runny runable library”


The end result is that in my code I will have simply pulling of

_ .HTMLBody = MyLengthyStreaming


Function Code description:
Rem 1
This uses the File System Object way discussed above to finally produce a long text string in variable _ MyLengthyStreaming _ This string probably has a of unnecessary stuff as well as the required part of the HTML code, but appears to be able to be handled and manipulated as if it were just the required part. Presumably the rest is ignored by things such as internet browsers

Rem 2
This allows for some extra simple string data to be added. If you are not familiar with HTML code then you can easily get the required string from text to HTML converters of which there are many freely available in internet
Note: If you have any “ in your required HTML string, then you will need to replace them in the given string in the VBA code with “”
http://www.excelfox.com/forum/showthread.php/2222-apply-NumberFormat#post10448






' https://support.microsoft.com/en-in/kb/186118
https://www.youtube.com/watch?v=nj8mU3ecwsM
https://www.youtube.com/watch?v=f8s-jY9y220&t=1813s




Note: ' path in code must be changed to reflect where you save .htm file
Pubic Function MyLengthyStreaming() As String

Public Function MyLengthyStreaming() As String
Rem 1 Make a long string from a Microsoft Word doc
'1(i) makes available the Library of stuff, objects, Methods etc.
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
'1(ii) makes the big File Object " Full path and file name of Word doc saved as .htm "
Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan 2016\ProMessage.htm"): Debug.Print FileObject ' path in code must be changed to reflect where you save it
'1(iii) sets up the data "stream highway"
Dim Textreme As Object: Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2) ' reading only, Opens using system default https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
'1(iv) pulls in the data, in our case into a simple string variable
Let MyLengthyStreaming = Textreme.ReadAll ' Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
Textreme.Close
Set Textreme = Nothing
Set Fso = Nothing
Rem 2 possible additions to MyLengthyStreaming



Rem 2
Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
End Function



MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"


Public Function MyLengthyStreaming() As String
Rem 1 Make a long string from a Microsoft Word doc
'1(i) makes available the Library of stuff, objects, Methods etc.
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
'1(ii) makes the big File Object " Full path and file name of Word doc saved as .htm "
Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan 2016\ProMessage.htm"): Debug.Print FileObject
'1(iii) sets up the data "stream highway"
Dim Textreme As Object: Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2) ' reading only, Opens using system default https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
'1(iv) pulls in the data, in our case into a simple string variable
Let MyLengthyStreaming = Textreme.ReadAll ' Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
Textreme.Close
Set Textreme = Nothing
Set Fso = Nothing
Rem 2 possible additions to MyLengthyStreaming
Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
End Function


Results Example:

Used htm Word File.JPG : https://imgur.com/mwihFBT
"ProMessage.htm" ( Saved from Word as .htm ) : https://app.box.com/s/cbtodk5srg76a5lowfemrdvei91mfmdq
1969

Recieved Email gmail.jpg : https://imgur.com/x0NybLa :

'.To = "Doc.AElstein@t-online.de"
.To = "excelvbaexp@gmail.com"
1972


Recieved EMail Telekom : https://imgur.com/wqPJSCt
Recieved EMail Telekom 2.JPG : https://imgur.com/o5mRkak

.To = "Doc.AElstein@t-online.de"
'.To = "excelvbaexp@gmail.com"
19701971








_.________________________________________________ ____________________________

Uploaded file had to be done as .docx to get it to upload at excelfox ( .htm were not permitted to be uploaded )
To use in code it must be resaved as .html ( ' and path in code must be changed to reflect where you save it )

[DocAElstein]

HTML as seen in Text Editor, for this Post:
http://www.excelfox.com/forum/showthread.php/2146-%E0%A4%AC%E0%A5%8D%E0%A4%B2%E0%A5%89%E0%A4%97-%E0%A4%95%E0%A5%8B%E0%A4%B6%E0%A4%BF%E0%A4%B6-%E0%A4%95%E0%A4%B0-%E0%A4%B0%E0%A4%B9%E0%A4%BE-%E0%A4%B9%E0%A5%88-%D8%A8%D9%84%D8%A7%DA%AF%D8%B2-%DA%A9%DB%8C-%DA%A9*Trying-Blogs?p=10524#post10524

OpenProMessageHTMLWithTextEditor.JPG : https://imgur.com/4zev9Kv

ProMessageHTMLInTextEditor.JPG : https://imgur.com/eTUd17q




<body lang=DE style='tab-interval:35.4pt'>

<div class=WordSection1>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Times","serif";color:black'>T <span class=SpellE>Andale</span>
Mono</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='color:red'>&nbsp;</span><span
style='font-size:10.0pt;font-family:"Arial","sans-serif";color:red'>T Arial</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-family:"Arial Black","sans-serif";
color:#FF9900'>T Arial Black</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Comic Sans MS";color:#99CC00'>T Comic <span class=SpellE>Sans</span>
MS</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Courier New";color:#33CCCC'>T Courier New</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Georgia","serif";color:#3366FF'>T Georgia</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Helvetica","sans-serif";color:purple'>T <span class=SpellE>Helvetics</span></span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Impact","sans-serif";color:#999999'>T Impact</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Tahoma","sans-serif";color:#993300'>T <span class=SpellE>Tahoma</span></span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"monaco","serif";color:fuchsia'>T Terminal</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
color:olive'>T Times New Roman</span></p>

<p style='margin:0cm;margin-bottom:.0001pt'><span style='font-size:10.0pt;
font-family:"Trebuchet MS","sans-serif";color:#FF6600'>T <span class=SpellE>Trebuchet</span>
MS</span></p>

<p class=MsoNormalCxSpFirst><o:p>&nbsp;</o:p></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:9.0pt;line-height:115%;
font-family:"Verdana","sans-serif";color:#C00000'>W9 <span class=SpellE>Verdana</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-family:"Arial Narrow","sans-serif";
color:red'>W11 Arial <span class=SpellE>Narrow</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:14.0pt;line-height:115%;
font-family:"Batang","serif";color:#FFC000'>W14 <span class=SpellE>Batang</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:16.0pt;line-height:115%;
mso-ascii-font-family:Calibri;mso-fareast-font-family:Batang;mso-hansi-font-family:
Calibri;color:#92D050'>W16 Calibri<o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:18.0pt;line-height:115%;
font-family:"Cambria Math","serif";mso-fareast-font-family:Batang;color:#00B050'>W18
<span class=SpellE>Cambri</span> <span class=SpellE>Math</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:20.0pt;line-height:115%;
font-family:FangSong;color:#00B050'>W20 <span class=SpellE>FangSong</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:22.0pt;line-height:115%;
font-family:"Gungsuh","serif";color:#00B0F0'>W22 <span class=SpellE>Gungsuh</span><o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:24.0pt;line-height:115%;
font-family:GungsuhChe;color:#0070C0'>W24 <span class=SpellE>GungsuhChe</span></span><span
style='font-size:24.0pt;line-height:115%;font-family:"Franklin Gothic Heavy","sans-serif";
mso-fareast-font-family:Batang;color:#0070C0'> <o:p></o:p></span></p>

<p class=MsoNormalCxSpMiddle><span style='font-size:26.0pt;line-height:115%;
font-family:"Times New Roman","serif";mso-fareast-font-family:Batang;
color:#002060'>W26 Times New Roman<o:p></o:p></span></p>

<p class=MsoNormalCxSpLast><span style='font-size:28.0pt;line-height:115%;
font-family:"Franklin Gothic Heavy","sans-serif";mso-fareast-font-family:Batang;
color:#7030A0'>W28 Franklin <span class=SpellE>Gothic</span><span
style='mso-spacerun:yes'> </span>Heavy<o:p></o:p></span></p>

</div>

</body>

</html>

[DocAElstein]

Function codes discussed in this Post:
http://www.excelfox.com/forum/showthread.php/2146-%E0%A4%AC%E0%A5%8D%E0%A4%B2%E0%A5%89%E0%A4%97-%E0%A4%95%E0%A5%8B%E0%A4%B6%E0%A4%BF%E0%A4%B6-%E0%A4%95%E0%A4%B0-%E0%A4%B0%E0%A4%B9%E0%A4%BE-%E0%A4%B9%E0%A5%88-%D8%A8%D9%84%D8%A7%DA%AF%D8%B2-%DA%A9%DB%8C-%DA%A9*Trying-Blogs?p=10527#post10527







Public Function MyLengthyStreaming() As String
Rem 1 Make a long string from a Microsoft Word doc
'1(i) makes available the Library of stuff, objects, Methods etc.
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
'1(ii) makes the big File Object " Full path and file name of Word doc saved as .htm "
Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan 2016\ProMessageTelekom.htm"): Debug.Print FileObject
'1(iii) sets up the data "stream highway"
Dim Textreme As Object: Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2) ' reading only, Opens using system default https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
'1(iv) pulls in the data, in our case into a simple string variable
Let MyLengthyStreaming = Textreme.ReadAll ' Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
Textreme.Close
Set Textreme = Nothing
Set Fso = Nothing
Let MyLengthyStreaming = MyLenghtyDiesScreaming_Telekom(MyLengthyStreaming) ' After this code line is done we have the string modified so that it gives the correct results in German Telekom Freemail t-online.de
Rem 2 possible additions to MyLengthyStreaming
'
'
'
'
End Function
'
' The second function below is mainly intended to make a modification to get the correct results in German Telekom Freemail t-online.de , but also the large html text not required from the start and a small amount at the end is also removed. (It does not need to be removed as it appears that it is ignored)
Public Function MyLenghtyDiesScreaming_Telekom(ByVal MyLengfyScream As String) As String ' Effectively this Dim's MyLenghtyDiesScreaming_Telekom as a String variable and MyLenghtyDiesScreaming_Telekom can be used as such in this function code. Assigning a variable to this in a main code will cause the value held by VBA in the variable MyLenghtyDiesScreaming_Telekom at that point to be out in the assigned variable, but fist the main code will be paused at this "calling" code line whilst the Function code is carried out. So we have the chance to do something in the function to fill that variable, MyLenghtyDiesScreaming_Telekom . We can take one or more things in in the ( ) to use . In this case we want to take a string in and then return it modified , hence the last code line is simply MyLenghtyDiesScreaming_Telekom = MyLengfyScream
Dim CntPus As Long ' A number constant for the positions of characters used in a couple of places. 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
' Take off all the first lot on unecessary required HTML
Let CntPus = InStr(1, MyLengfyScream, "<div class=WordSection1>", vbTextCompare) ' return the position (starting from the fist character , Looking in the string , for that text , doing a text comparison which is case insensitive )
Let MyLengfyScream = Mid(MyLengfyScream, CntPus + 26)
' Add to this array below all possible fonts in quotes I have to use Variant type as the VBA Array( ) Method used below pruduces a 1 dimmansional Array of Variant types. I may assing a dynamic Array of variant types to what the VBA Array( ) Function returns
Dim arsFonts() As Variant: Let arsFonts() = Array("""Andale Mono""", """Times""", """serif""", """Arial""", """sans-serif""", """Arial Black""", """Comic Sans MS""", """Courier New""", """Georgia""", """Helvetics""", """Impact""", """Tahoma""", """Terminal""", """monaco""", """Times New Roman""", """Trebuchet MS""", """Verdana""", """Arial Narrow""", """Batang""", """Calibri""", """Cambri Math""", """FangSong""", """Gungsuh""", """GungsuhChe""", """Franklin Gothic Heavy""")
Dim arschFont As Variant ' It is a required syntax that the stearing element in the For Each loop to be Variant type or Object type, ( the object type can be Object or ther specific object. if I do not specify specifically then VBVA defaults to all simialr ngs in the thing you are going through ' http://www.excelfox.com/forum/showthread.php/2157-Re-Defining-multiple-variables-in-VBA?p=10192#post10192
' Look for things like "Font" and replace the " with an arbitrary string like ScrotumSack , so "Font" becomes ScrotumSackFontScrotumSack
For Each arschFont In arsFonts() ' Loop to look for and replce each Font held in "s with the same font but in 's
If InStr(1, MyLengfyScream, arschFont, vbTextCompare) > 1 Then ' case a Font in quotes , like "font" , so for that font in quotes... and ...
Dim FontSingleScrQuote As String: Let FontSingleScrQuote = Replace(arschFont, """", "ScrotumSack", 1, 2, vbBinaryCompare) ' ...Make a that font in ScrotumSack like ScrotumSackfontScrotumSack ... and ... I use ScrotumSack arbitrarily as I find it funny and I doubt anyone else does.. does use it, so I won't have that already in the text. I cannot go straight to using the ' because if I do that now then I won't be able to distinguisch the existing ' which I want to change to " in the next bit
Let MyLengfyScream = Replace(MyLengfyScream, arschFont, FontSingleScrQuote, 1, -1, vbTextCompare) ' .... replace all "fonts" with ScrotumSackfontsScrotumSack
Else ' no arsch Font in My lengfy scream
End If
Next arschFont
' replace any ' with " This is mainly intended to replace enclosed in ' strings like askjhhsa ='kasjhScrotumSackfontScrotumSackfcb qwq 63 = Bollocks' jdgsjag with askjhhsa ="kasjhScrotumSackfontScrotumSackfcb qwq 63 = Bollocks" jdgsjag
Let MyLengfyScream = Replace(MyLengfyScream, "'", """", 1, -1, vbTextCompare)
' Scratch my Scrotum sacks, - that is to say replace them with a with ' I can do this now since the existing ' have been changeed to " so the ScrotumSacks , which were originally "s , can now be chnged to 's
Let MyLengfyScream = Replace(MyLengfyScream, "ScrotumSack", "'", 1, -1, vbTextCompare)
' take last unecessary bit of HTML off
Let CntPus = InStrRev(MyLengfyScream, "</div>", -1, vbTextCompare) ' get the position counting from the left but looking from the right ( in MyLengfyScream , of </div> , start looking from end , make text comparison which is case insensitive )
Let MyLengfyScream = Left(MyLengfyScream, CntPus - 1)
' Finally we set here what is actually returned by virtue of effectively putting something in the pseudo variable MyLenghtyDiesScreaming_Telekom
Let MyLenghtyDiesScreaming_Telekom = MyLengfyScream
End Function

[DocAElstein]

Code for RaghavendraPrabhu
For this Post in main Excel Forum
http://www.excelfox.com/forum/showthread.php/2237-Make-macro-create-unique-files-only-once-If-files-exist-amend-them



Option Explicit

' https://stackoverflow.com/questions/46368771/how-to-create-a-new-workbook-for-each-unique-value-in-a-column?rq=1
' http://www.excelfox.com/forum/showthread.php/2237-Make-macro-create-unique-files-only-once-If-files-exist-amend-them
Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long
Dim y As Long
Dim ct As Long
Dim uCol As Long

'On Error GoTo ErrHandler

'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

'Your main worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

'Column G
uCol = 7
ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
unique(ct) = ActiveSheet.Cells(x, uCol).Text
ct = ct + 1
End If
Next x

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
If unique(x) <> "" Then
If Dir(ThisWorkbook.Path & "\" & unique(x) & ".xlsx", vbNormal) = "" Then 'If unique file does not exist
'add workbook
Workbooks.Add: Set wb(x) = ActiveWorkbook
ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
Else ' open workbook
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & unique(x) & ".xlsx"
Set wb(x) = ActiveWorkbook
End If


'loop to find matching items in ws and copy over
For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
If ws.Cells(y, uCol) = unique(x) Then
'copy full formula over
'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb( x).Sheets(1).Columns(uCol)) + 1, 1)
'to copy and paste values
ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb( x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)
wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb( x).Sheets(1).Columns(uCol)), 6).Value = Format(Date, "dd mmm yyyy")
End If
Next y
'autofit
wb(x).Sheets(1).Columns.AutoFit
'save when done
wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' & " " & Format(Now(), "mm-dd-yy")
wb(x).Close SaveChanges:=True
Else
'once reaching blank parts of the array, quit loop
Exit For
End If

Next x
' Master File change to current date:
Dim Lr As Long: Let Lr = ws.Cells(Rows.Count, 6).End(xlUp).Row
ws.Range("F2:F" & Lr & "").Value = Format(Date, "dd mmm yyyy")

' Application.ScreenUpdating = True
' Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function

[DocAElstein]

Second Code for RaghavendraPrabhu
For this Post in main Excel Forum
http://www.excelfox.com/forum/showthread.php/2237-Make-macro-create-unique-files-only-once-If-files-exist-amend-them?p=10541#post10541







Option Explicit

' https://stackoverflow.com/questions/46368771/how-to-create-a-new-workbook-for-each-unique-value-in-a-column?rq=1
' http://www.excelfox.com/forum/showthread.php/2237-Make-macro-create-unique-files-only-once-If-files-exist-amend-them
Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long
Dim y As Long
Dim ct As Long
Dim uCol As Long

'On Error GoTo ErrHandler

'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

'Your main worksheet info.
Set ws = ActiveWorkbook.Sheets("Sheet1")
Let uCol = 7 'Column G
Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
Let ws.Range("F" & Strt & ":F" & Stp & "").Value = Format(Date, "dd mmm yyyy") ' adding the dates to the new rows
Let ws.Range("A" & Strt & ":A" & Stp & "").Value = Application.Evaluate("=row(" & Strt & ":" & Stp & ")-1") ' adding the S.no. to the new rows

ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
unique(ct) = ActiveSheet.Cells(x, uCol).Text
ct = ct + 1
End If
Next x

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
If unique(x) <> "" Then
If Dir(ThisWorkbook.Path & "\" & unique(x) & ".xlsx", vbNormal) = "" Then 'If unique file does not exist
'add workbook
Workbooks.Add: Set wb(x) = ActiveWorkbook
ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
Else ' open workbook
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & unique(x) & ".xlsx"
Set wb(x) = ActiveWorkbook
End If


'loop to find matching items in ws starting from where column F ( 6 ) has no entry and copy over
'For y = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
For y = Strt To Stp
If ws.Cells(y, uCol) = unique(x) Then
'copy full formula over
'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb( x).Sheets(1).Columns(uCol)) + 1, 1)
'to copy and paste values
ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb( x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb (x).Sheets(1).Columns(uCol)), 6).Value = Format(Date, "dd mmm yyyy")
End If
Next y
'autofit
wb(x).Sheets(1).Columns.AutoFit
'save when done
wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' & " " & Format(Now(), "mm-dd-yy")
wb(x).Close SaveChanges:=True
Else
'once reaching blank parts of the array, quit loop
Exit For
End If

Next x
'' Master File change to current date:
'Dim Lr As Long: Let Lr = ws.Cells(Rows.Count, 6).End(xlUp).Row
' ws.Range("F2:F" & Lr & "").Value = Format(Date, "dd mmm yyyy")

' Application.ScreenUpdating = True
' Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function