Appendix Thread. 3 *

[DocAElstein]

August 1 2023
Thread 2915
First post, this one, is #post22100
This is a quick fix to get some of the posts from the Appendix 2 made around November 2019, and stupidly deleted by me today 1 Aug 2023
From page 15 , this Thread should be left alone, please.






https://www.excelfox.com/forum/showthread.php/2915-Appendix-Thread-3?p=22100&viewfull=1#post22100





The stuff below is wrong, but may give a clue where this post came from...

For more recent posts on the App Index Rws() Clms() idea, see from approximately page 50
https://www.excelfox.com/forum/showthread.php/2837-Appendix-Thread-App-Index-Rws()-Clms()-Majic-code-line-Codings-for-other-Threads-Tables-etc-)/page50
, and the best, most recent will be from about page 53
https://www.excelfox.com/forum/showthread.php/2837-Appendix-Thread-App-Index-Rws()-Clms()-Majic-code-line-Codings-for-other-Threads-Tables-etc-)/page53



Other posts before this may be subject to change and testing experiments





This thread will become the main Blog thread for posts on the App Index Rws() Clms() idea




































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>



This thread 2837
https://excelfox.com/forum/showthread.php/2837-Appendix-Thread-App-Index-Rws()-Clms()-Majic-code-line-Codings-for-other-Threads-Tables-etc-)

This Post #post19050 https://excelfox.com/forum/showthread.php/2837-Appendix-Thread-App-Index-Rws()-Clms()-Majic-code-line-Codings-for-other-Threads-Tables-etc-)?p=19050&viewfull=1#post19050
https://excelfox.com/forum/showthread.php/2837-Appendix-Thread-App-Index-Rws()-Clms()-Majic-code-line-Codings-for-other-Threads-Tables-etc-)#post19050



(Copied from 2834)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2 (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg)

[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






https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

sjflsdjfsdklfj




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Alternative Codes using [ ] shorthand
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

More Named Range Scope Wonks. Problems when Worksheet Scoped WorkSheet is different from Worksheet refered to in RefersTo:= Range Object argument


Here is a another partial solution to the This Thread
http://www.excelforum.com/excel-programming-vba-macros/1141369-evaluate-and-differences-evaluated-array-return-needs-extra-bracket-for.html

It was also used to answer a few questions I had here:
http://www.thespreadsheetguru.com/blog/the-vba-guide-to-named-ranges[I] ( Comment 22 )
Here is what I wrote there:
Reply Posted at
http://www.thespreadsheetguru.com/blog/the-vba-guide-to-named-ranges
6 th June 2016:

Hi
Hi Just feeding back from my "experiments" over the weekend_...
http://www.excelforum.com/showthread.php?t=1141369&page=2&p=4404276&highlight=#post4404276
_..So now o answer my questions:
_1) I have not yet seen anything to suggest the answer to that is not yes.


ht[color=white]tps://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2 (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg)




https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgwWg8x2WxLSxxGsUP14AaABAg.9k3ShckGnhv9k89Lsaig oO)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2 (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxxxIaK1pY8nNvx6JF4AaABAg.9k-vfnj3ivI9k8B2r_uRa2)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=UgxKFXBNd6Pwvcp4Bsd4AaABAg)
https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg (https://www.youtube.com/watch?v=yVgLmj0aojI&lc=Ugw9X6QS09LuZdZpBHJ4AaABAg)

[DocAElstein]

Referrences in suppost of this post:
http://www.excelfox.com/forum/showthread.php/2130-Sort-an-array-based-on-another-array-VBA?p=9985#post9985

and solution to this post
http://www.excelforum.com/excel-programming-vba-macros/1160648-how-to-create-a-pop-up-notification-for-two-different-conditions-at-the-same-time.html#post4507157



' http://www.snb-vba.eu/VBA_Arraylist_en.html
' http://www.snb-vba.eu/VBA_Arraylist_en.html#L_11.3


' https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/comment-page-1/#comment-587

' https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/comment-page-1/#comment-515






' https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/comment-page-1/#comment-587
Sub M_snbSortof() ' http://www.snb-vba.eu/VBA_Arraylist_en.html#L_11.3
Dim rngVoll As Range: Set rngVoll = Tabelle3.Range("A1:E10")
Dim snAll() As Variant, Sported() As Variant
Let snAll() = rngVoll.Value
Dim j As Long, jj As Long
With CreateObject("System.Collections.Arraylist")
For j = 1 To UBound(snAll(), 1)
.Add snAll(j, 3)
Next
.Sort
Let Sported() = .ToArray
.Clear
For j = 0 To UBound(Sported())
For jj = 1 To UBound(snAll(), 1)
If snAll(jj, 3) = Sported(j) Then
' Use Range to overcome Array size Limits of Worksheets Functions
'Dim Clm As Range: Set Clm = Application.Index(rngVoll, jj, 0)
' .Add Clm.Value
' .Add (Application.Index(rngVoll, jj, 0).Value)

' Use Cells to overcome Array size Limits of Worksheets Functions
Dim LB As Long, UB As Long '…User Given start and Stop Column as a Number
Let LB = LBound(snAll(), 2): Let UB = UBound(snAll(), 2)
Dim strLtrLB As String, strLtrUB As String '…Column Letter corresponding to Column Number
'There are many ways to get a Column Letter from a Column Number – excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
Let strLtrLB = Split(Cells(1, LB).Address, "$")(1) 'An Address Method
Let strLtrUB = Replace (Replace(Cells(1, UB).Address, "1", ""), "$", "") 'A Replace Method
'Obtain Column Indicies using Spreadsheet Function Column via VBA Evaluate Method
Dim clms() As Variant
Let clms() = Evaluate("column(" & strLtrLB & ":" & strLtrUB & ")") 'Returns 1 D “pseudo” Horizontal Array of sequential numbers from column number of LB to UB
'Or
clms() = Evaluate("column(" & Split(Cells(1, LB).Address, "$")(1) & ":" & Replace (Replace(Cells(1, UB).Address, "1", ""), "$", "") & ")")
.Add (Application.Index(Tabelle3.Cells, jj, clms()))

'Let snAll(jj, 3) = ""
Exit For
End If
Next jj
Next j
For j = 0 To .Count - 1
Tabelle3.Cells(j + 1 + 10, 1).Resize(, UBound(snAll, 2)) = .Item(j)
Next j
End With
End Sub
'
Sub M_snb()
Dim sn, sp, j As Long, jj As Long
sn = Tabelle3.Range("A1:E10")
With CreateObject("System.Collections.Arraylist")
For j = 1 To UBound(sn)
.Add sn(j, 3)
Next
.Sort
sp = .ToArray
.Clear
For j = 0 To UBound(sp)
For jj = 1 To UBound(sn)
If sn(jj, 3) = sp(j) Then
.Add Application.Index(sn, jj)
sn(jj, 3) = ""
Exit For
End If
Next
Next
For j = 0 To .Count - 1
Tabelle3.Cells((j + 1) + 10, 1).Resize(, UBound(sn, 2)) = .Item(j)
Next
End With
End Sub































'Rem Ref
' http://www.excelforum.com/excel-programming-vba-macros/1139207-how-to-move-a-userform-and-module-from-one-book-to-another-2.html
' http://www.excelforum.com/excel-programming-vba-macros/1138300-vba-userform-value-check-if-user-form-buttons-checked-not-working-check-button-on-open.html
' http://www.excelforum.com/excel-programming-vba-macros/1139742-workbooks_open-crashes-when-file-opened-with-code-manually-open-ok-userform-issue.html
' http://www.excelfox.com/forum/showthread.php/2130-Sort-an-array-based-on-another-array-VBA?p=9985#post9985
' http://www.snb-vba.eu/VBA_Arraylist_en.html
' http://www.snb-vba.eu/VBA_Arraylist_en.html#L_11.3
' http://www.excelforum.com/showthread.php?t=1154829&page=4#post4502593
' http://www.excelforum.com/excel-programming-vba-macros/1160648-how-to-create-a-pop-up-notification-for-two-different-conditions-at-the-same-time.html#post4507157
' http://www.excelfox.com/forum/showthread.php/2130-Sort-an-array-based-on-another-array-VBA?p=9985#post9985






http://www.excelforum.com/showthread.php?t=1154829&page=4#post4502593


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)





https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Hi Nelson,
I think both
_ the ways to do this,
_and the possibly output forms
are infinite

_ You must try to be a bit more precise in exactly what you want.

_ I have done another fairly simple code:

It is here:
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10047#post10047

It runs though all the Worksheets to calculate normal overtime and holiday overtime. The total added for all Worksheets is displayed in a message box:
NelsonMessageBox.jpg http://imgur.com/XSvQpQi
1863




I expect the code is not yet want you finally want. It tells you the total sum for Normal Overtime and Holiday overtime.
( I still do not understand what calculations should be done for total days :confused: )

Please start a new Thread here: _.. http://www.excelfox.com/forum/forumdisplay.php/2-Excel-Help

_.. Please try again to explain exactly what you want.
_.. I will then look at it again for you on Monday

:)
Alan

Code:

' An Initial code for Nelson for Post in this Forum http://www.excelfox.com/forum/forumdisplay.php/2-Excel-Help
Sub SomeingSumTotals() ' https://www.dropbox.com/s/u76eo5trrtppgoi/SAMPLE2.xlsx?dl=0
Rem 1) Worksheets info.
Dim WsStear As Worksheet ' 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: 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
Rem 2) varables for some totals ;)
Dim NOHrsV2 As Double, HOHrsV2 As Double, TDays As Long
Let NOHrsV2 = 0: Let HOHrsV2 = 0: Let TDays = 0
Rem 3) Loop through worksheets and give some Totals
Dim Cnt As Long ' Loop Bound variable count for going through all worksheets
For Cnt = 1 To ThisWorkbook.Worksheets.Count
Set WsStear = ThisWorkbook.Worksheets.Item(Cnt) ' 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 lr 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. )
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("A2") ' Worksheets Range(" ") Property used to return Range object of first cell in second row
Dim arrInNorm() As Variant, arrInOver() As Variant ' In the next lines the .Value2 Property is applied a Range object which presents the the 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, 1).Value2 ' 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.. ) )
Let arrInOver() = FstDtaCel.Offset(0, 9).Resize(lr - 1, 1).Value2 ' 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.
Dim ShtCnt As Long ' Loop Bound Variable Count for hours columns looping
For ShtCnt = 1 To UBound(arrInNorm(), 1) Step 1
If arrInNorm(ShtCnt, 1) <> 0 And arrInOver(ShtCnt, 1) <> 0 Then Let NOHrsV2 = NOHrsV2 + arrInOver(ShtCnt, 1)
If arrInNorm(ShtCnt, 1) = 0 And arrInOver(ShtCnt, 1) <> 0 Then Let HOHrsV2 = HOHrsV2 + arrInOver(ShtCnt, 1)
Next ShtCnt
Next Cnt
Rem 4) Output some totals ;)
MsgBox prompt:="Normal Overtime is " & NOHrsV2 * 24 & vbCrLf & "Holiday Overtime is" & HOHrsV2 * 24 ' NelsonMessageBox.jpg http://imgur.com/XSvQpQi
'4b) Tell you Totals ' Sub Speach() ' Richard Buttrey http://www.excelforum.com/showthread.php?t=1164765&p=4535112#post4535112
Dim Saps As Object
Set Saps = CreateObject("SAPI.SpVoice")
Saps.Speak "Hello Nelson. These are Sum totals for Normal Overtime and Holiday Overtime for the two Worksheets you gave.. Normal Overtime is " & NOHrsV2 * 24 & ".. Holiday Overtime is " & HOHrsV2 * 24 & ".. I expect this is not yet quite what you want."
' ' End Sub
End Sub https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code for Nelson in this Thread
http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime
http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10060#post10060



Option Explicit
Sub IJAdjustTotalAllWorksheet() ' 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 NOHrsV2 As Double, HOHrsV2 As Double ' I am proposing to use the underlying number an adjust as necerssary to get the reqired format
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
Let NOHrsV2 = 0: Let HOHrsV2 = 0 ' The varaibles are emtied before run for each worksheet
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 arrDte() As Variant, arrTotHrs() 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 arrDte() = FstDtaCel.Offset(0, 4).Resize(lr, 1).Value ' E ' 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.. )
Let arrTotHrs() = FstDtaCel.Offset(0, 7).Resize(lr, 1).Value ' H ' 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:

Dim arrInNorm() As Variant, arrInOver() As Variant
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
'3c) Inner loop for rows
Dim ShtCnt As Long ' Loop Bound Variable Count for hours columns looping
For ShtCnt = 1 To UBound(arrDte(), 1) Step 1 '------------------- For "rows" in data arrays
'3d) We need to check for a Holy?? Holiday?? Friday?? 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
Let Dte = arrDte(ShtCnt, 1): Let DteNo = Weekday(Dte, [vbSunday]) ' I do not really nead this extra variable, but for dates I prefer always to do this to help in looking into the variable in Debugging
If DteNo = 6 Then ' 6 I think is Friday, Nelson's Holy HoliDay ?
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
Let arrInOver(ShtCnt, 1) = arrTotHrs(ShtCnt, 1) ' Given To ' Added to arrInOver(ShtCnt, 1) + arrTotHrs(ShtCnt, 1)
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
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
End If
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"o
Else ' No Holy Holiday
End If
'3e)
If arrInNorm(ShtCnt, 1) <> 0 And arrInOver(ShtCnt, 1) <> 0 Then Let NOHrsV2 = NOHrsV2 + arrInOver(ShtCnt, 1) ' Normal Overtime is simply calculated from summing hours in column J only If there are Overtime hours in column J And there are Normal hours are in column I.
If arrInNorm(ShtCnt, 1) = Empty And arrInOver(ShtCnt, 1) <> 0 Then Let HOHrsV2 = HOHrsV2 + arrInOver(ShtCnt, 1) ' Holiday Overtime is simply calculated from summing hours in column J only If there are Overtime hours in column J And there are no Normal hours are in column I.
Next ShtCnt '--------------------------End Inner loop for rows-----
'3f) Paste out final Totals and days to current Worksheet
Let wsStear.Range("G34").Value = NOHrsV2 * 24 'Normal Overtime is held in Array as fraction of a day
Let wsStear.Range("J34").Value = HOHrsV2 * 24 'Holiday Overtime is held in Array as fraction of a day
Let wsStear.Range("C34").Value = TDays ' The constant value of Total days is simply added to cell C34
'3g) Normal Hrs ( Column I ) and Overtime Hrs ( Column J ) are changed
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
Let FstDtaCel.Offset(0, 8).Resize(lr, 1).Value2 = arrInNorm() ' I
Next Cnt '==End main Loop==============================================
End Sub


' Rem Ref '_- http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp?p=10062#post10062
'_- http://www.excelfox.com/forum/showthread.php/2138-Understanding-VBA-Range-Object-Properties-and-referring-to-ranges-and-spreadsheet-cells?p=10012#post10012

[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



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)





https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

'Testies: NOT FINAL CODE --- TEST CODE FOR LATER REFERRENCE ! TEST ! --- Testies to you '_-
' Code for approximately Posts: 14 - 23
Sub IJAdjustLAddTotalAllWorksheetCode3()

For Thread ' http://www.excelfox.com/forum/showthread.php/2144-Code-Required-to-calculate-number-of-days-worked-normal-overtime-and-holiday-overtime?p=10078#post10078

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Test


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)





https://www.youtube.com/watch?v=vXyMScSbhk4 (https://www.youtube.com/watch?v=vXyMScSbhk4)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgynOSp1dleo-Z8L_QN4AaABAg.9jJLDC1Z6L-9k68CuL4aTY (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgynOSp1dleo-Z8L_QN4AaABAg.9jJLDC1Z6L-9k68CuL4aTY)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwV5N_ulFXYMNbyQG54AaABAg.9itCkoVN4w79itOVYVvE wQ (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwV5N_ulFXYMNbyQG54AaABAg.9itCkoVN4w79itOVYVvE wQ)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgyOh-eR43LvlIJLG5p4AaABAg.9isnKJoRfbL9itPC-4uckb (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgyOh-eR43LvlIJLG5p4AaABAg.9isnKJoRfbL9itPC-4uckb)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugy1B1aQnHq2WbbucmR4AaABAg.9isY3Ezhx4j9itQLuif2 6T (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugy1B1aQnHq2WbbucmR4AaABAg.9isY3Ezhx4j9itQLuif2 6T)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgxxajSt03TX1wxh3IJ4AaABAg.9irSL7x4Moh9itTRqL7d Qh (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgxxajSt03TX1wxh3IJ4AaABAg.9irSL7x4Moh9itTRqL7d Qh)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwJAAPbp8dhkW2X1Uh4AaABAg.9iraombnLDb9itV80HDp Xc (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwJAAPbp8dhkW2X1Uh4AaABAg.9iraombnLDb9itV80HDp Xc)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgzIzQ6MQ5kTpuLbIuB4AaABAg.9is0FSoF2Wi9itWKEvGS Sq (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgzIzQ6MQ5kTpuLbIuB4AaABAg.9is0FSoF2Wi9itWKEvGS Sq)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Final Results for this Thread Post
http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder?p=10575#post10575

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

fja.fjkaj

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code in support of these Threads:
[size=1] 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=10582#post10582

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Using this File:
“UpdatesOnVistaAspire4810TZG25thMarch.txt” : https://app.box.com/s/z90o8yj7iz0188yci34mu7gahe2tfhce
That file is downloaded into the same Folder as the file containing the code from the last Post.
This code line needs to have that text file reference in it such:
Let ActiviEL = ThisWorkbook.Path & "\UpdatesOnVistaAspire4810TZG25thMarch.txt"
Run code entering these search values when prompted
2553154 2726958 2965291 2920813 3054873 974554

Here the output string

You looked for
2553154
2726958
2965291
2920813
3054873
974554

Finded was

_.______________________________________________


Using this File:
“UpdatesAcerMartinWin7Pro64Bit26thMarch.txt” : https://app.box.com/s/8m96l0e7yh1wcb15y06eaaz6a7vtjzgd
That file is downloaded into the same Folder as the file containing the code from the last Post.
This code line needs to have that text file reference in it such:
Let ActiviEL = ThisWorkbook.Path & "\“UpdatesAcerMartinWin7Pro64Bit26thMarch.txt"
Run code entering these search values when prompted
2553154 2726958 2965291 2920813 3054873 974554

Here the output string

You looked for
2553154
2726958
2965291
2920813
3054873
974554

Finded was

[DocAElstein]

Appendix notes in support of these Threads:
http://www.excelfox.com/forum/showthread.php/2242-Excel-2003-ActiveX-controls-embedded-in-worksheet-not-working-then-can%E2%80%99t-even-insert-them
http://www.excelfox.com/forum/showthread.php/2241-VBA-Worksheet-Buttons-Form-controls-Command-Buttons-verses-ActiveX-controls-Command-Buttons

Trying to find .exd files and delete them.
The results of most of what I have read or results of asking people suggests that they are usually findable if you look for a temp or temp somewhere in a file path

These appear a bit difficult to find sometimes . You can try:

_ manually navigating

_ a windows explorer search for *.exd
StarDotexeExplorerSearch.JPG : https://imgur.com/hfbC93Z
2037

_ a search in a small bar using %temp% or %Temp%
You can get the small bar from either hitting WindowsKey+r or by selecting the Windows symbol
PerCenttempPerCentsearch.JPG : https://imgur.com/LypHLGY
2038
PerCenttempPerCentsearch2.jpg : https://imgur.com/DZvycco
2039

It seems a bit inconsistent which search finds what, but usually it is said that you find important places looking something like these:
C:\Users\username\AppData\Local\Temp\Excel8.0
C:\Users\username\AppData\Local\Temp\VBE

I found sometimes .exd files here also
C:\Users\username\Application Data\Microsoft\Forms

Some other typical places I found
C:\Dokumente und Einstellungen\Administrator\Application Data\Microsoft\Forms
C:\Dokumente und Einstellungen\Administrator\AppData\LocalLow

_.____._____________________

This is one of my typical attempts to get a ActiveX control button to_... either
_ insert into worksheet
or , if already three
_ work
_... by deleting .exd files

What I typically tried:
I looked here C:\Users\Elston\AppData\Local\Temp\Excel8.0
I found this:
C Users Elston AppData Local Temp Excel8.0.jpg https://imgur.com/doXstmr
2040

I deleted that MSForms.exd File ( Excel had to be closed to do that ) : It had no effect. ( By the way, MSForms.exd gets made again every time I hit the button, or it appears to get made as soon as I open any file that either has or has ever had a control embedded in a worksheet)


In C:\Users\Elston\AppData\Local\Temp\VBE I found these:
C Users Elston AppData Local Temp VBE.jpg https://imgur.com/wjaZpXp
2041

So…for these files I did:…
MSComctlLib.exd : I deleted this , - no effect
MSForms.exd : This could not be deleted with Excel 2003 open, it can when it is closed. But that had no effect
RefEdit.exd : This could not be deleted with Excel 2003 open, it can when it is closed. But no that had effect
( By the way, MSForms.exd and RefEdit.exd get made again every time I hit the button, or it appears to get made as soon as I open any file that either has, or has ever had, a control embedded in a worksheet )


In C:\Users\Elston\Application Data\Microsoft\Forms
I found these:
( https://imgur.com/Lv2kyhk )

So……for these files I did:…
RefEdit.exd This could not be deleted with Excel 2003 open, it can when it is closed. But that had no effect
mscomctllib.exd I deleted this: That had no effect
SHDocVw.exd I deleted this: That had no effect
( By the way, MSForms.exd gets made again every time I hit the button, or it appears to get made as soon as I open any file that either has or has ever had a control embedded in a worksheet)

_.._______________-

So for me none of that helped to get me a working ActiveX control Button in a worksheet.

:(

[DocAElstein]

Screenshots and extra notes in support of this Thread:
http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder?p=10595#post10595



Distributed Files for the day for "Raghu.xlsx"
From Raghu
Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00
15. Mrz 18Raghu


3
5ABC05
$ 7.22
62
$ 447.64
15. Mrz 18Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99
15. Mrz 18Raghu


5
13ABC13
$ 8.51
12
$ 102.12
15. Mrz 18Raghu


6
17ABC17
$ 11.99
1
$ 11.99
15. Mrz 18Raghu


7
21ABC21
$ 12.99
5
$ 64.95
15. Mrz 18Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55
15. Mrz 18Raghu


9
29ABC29
$ 13.66
7
$ 95.62
15. Mrz 18Raghu


10
33ABC33
$ 3.99
35
$ 139.65
15. Mrz 18Raghu


11
37ABC37
$ 55.00
22
$ 1,210.00
15. Mrz 18Raghu


12
41ABC41
$ 7.22
62
$ 447.64
15. Mrz 18Raghu


13
45ABC45
$ 741.99
101
$ 74,940.99
15. Mrz 18Raghu
Worksheet: FromRaghu



Or if distributed today, 2nd April
Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


3
5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


5
13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018Raghu


6
17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018Raghu


7
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


9
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


10
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


11
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


12
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


13
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu
Worksheet: Tabelle1

_.________________________

In next Post could be a typical returned worksheet from a team member : ( based on similar files in the Zip Folder "WorkDistributedAndConsolidated 16MAR18.zip" )

[DocAElstein]

From last post...

This could be a typical returned worksheet from a team member : ( based on similar files in the Zip Folder "WorkDistributedAndConsolidated 16MAR18.zip" )
Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00
15. Mrz 18RT1RT2RT3RT4
02. Apr 18Raghu


3
5ABC05
$ 7.22
62
$ 447.64
15. Mrz 18RT1RT2RT3RT4
02. Apr 18Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99
15. Mrz 18RT1RT2RT3RT4
02. Apr 18Raghu


5
13ABC13
$ 8.51
12
$ 102.12
15. Mrz 18RT1RT2RT3RT4
02. Apr 18Raghu


6
17ABC17
$ 11.99
1
$ 11.99
15. Mrz 18RT1RT2RT3RT4
02. Apr 18Raghu


7
21ABC21
$ 12.99
5
$ 64.95
15. Mrz 18Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55
15. Mrz 18Raghu


9
29ABC29
$ 13.66
7
$ 95.62
15. Mrz 18Raghu


10
33ABC33
$ 3.99
35
$ 139.65
15. Mrz 18Raghu


11
37ABC37
$ 55.00
22
$ 1,210.00
15. Mrz 18Raghu


12
41ABC41
$ 7.22
62
$ 447.64
15. Mrz 18Raghu


13
45ABC45
$ 741.99
101
$ 74,940.99
15. Mrz 18Raghu
Worksheet: FromRaghu

or this
Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


3
5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


5
13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


6
17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


7
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


9
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


10
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


11
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


12
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


13
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu
Worksheet: Tabelle1

[DocAElstein]

For this Post
http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder?p=10595#post10595

Daily data files completed by team members:
John


S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated


2ABC02
$ 13.66
7
$ 95.62 02.Apr.2018JT1JT2JT3JT402.Apr.2018


6ABC06
$ 3.99
35
$ 139.65 02.Apr.2018JT1JT2JT3JT402.Apr.2018


10ABC10
$ 55.00
22
$ 1,210.00 02.Apr.2018JT1JT2JT3JT402.Apr.2018


14ABC14
$ 7.22
62
$ 447.64 02.Apr.2018JT1JT2JT3JT402.Apr.2018


18ABC18
$ 741.99
101
$ 74,940.99 02.Apr.2018JT1JT2JT3JT402.Apr.2018


22ABC22
$ 8.51
12
$ 102.12 02.Apr.2018JT1JT2JT3JT402.Apr.2018


26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018
Worksheet: Tabelle1

Greg


3ABC03
$ 12.99
5
$ 64.95 02.Apr.2018GT1GT2GT3GT402.Apr.2018


7ABC07
$ 333.45
99
$ 33,011.55 02.Apr.2018GT1GT2GT3GT402.Apr.2018


11ABC11
$ 13.66
7
$ 95.62 02.Apr.2018GT1GT2GT3GT402.Apr.2018


15ABC15
$ 3.99
35
$ 139.65 02.Apr.2018GT1GT2GT3GT402.Apr.2018


19ABC19
$ 55.00
22
$ 1,210.00 02.Apr.2018GT1GT2GT3GT402.Apr.2018


23ABC23
$ 7.22
62
$ 447.64 02.Apr.2018
Worksheet: Tabelle1

Margret


4ABC04
$ 8.51
12
$ 102.12 02.Apr.2018MT1MT2MT3MT402.Apr.2018


8ABC08
$ 11.99
1
$ 11.99 02.Apr.2018MT1MT2MT3MT402.Apr.2018


12ABC12
$ 12.99
5
$ 64.95 02.Apr.2018MT1MT2MT3MT402.Apr.2018


16ABC16
$ 333.45
99
$ 33,011.55 02.Apr.2018MT1MT2MT3MT402.Apr.2018


20ABC20
$ 13.66
7
$ 95.62 02.Apr.2018MT1MT2MT3MT402.Apr.2018


24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018MT1MT2MT3MT402.Apr.2018


28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018MT1MT2MT3MT402.Apr.2018


32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018
Worksheet: Tabelle1


Raghu
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


3
5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


5
13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


6
17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


7
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu
Worksheet: Tabelle1

[DocAElstein]

From last Post... master File After Distribition and before Consolidation
File: “zMasterBeforeConsolidation.xlsm”
https://app.box.com/s/818q2ev3owpini2202n3dqp3xxicfeif



S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member
Checked


1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


2ABC02
$ 13.66
7
$ 95.62 02.Apr.2018John


3ABC03
$ 12.99
5
$ 64.95 02.Apr.2018Greg


4ABC04
$ 8.51
12
$ 102.12 02.Apr.2018Margaret


5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


6ABC06
$ 3.99
35
$ 139.65 02.Apr.2018John


7ABC07
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


8ABC08
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


10ABC10
$ 55.00
22
$ 1,210.00 02.Apr.2018John


11ABC11
$ 13.66
7
$ 95.62 02.Apr.2018Greg


12ABC12
$ 12.99
5
$ 64.95 02.Apr.2018Margaret


13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018Raghu


14ABC14
$ 7.22
62
$ 447.64 02.Apr.2018John


15ABC15
$ 3.99
35
$ 139.65 02.Apr.2018Greg


16ABC16
$ 333.45
99
$ 33,011.55 02.Apr.2018Margaret


17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018Raghu


18ABC18
$ 741.99
101
$ 74,940.99 02.Apr.2018John


19ABC19
$ 55.00
22
$ 1,210.00 02.Apr.2018Greg


20ABC20
$ 13.66
7
$ 95.62 02.Apr.2018Margaret


21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


22ABC22
$ 8.51
12
$ 102.12 02.Apr.2018John


23ABC23
$ 7.22
62
$ 447.64 02.Apr.2018Greg


24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018Margaret


25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018John


27ABC27
$ 741.99
101
$ 74,940.99 02.Apr.2018Greg


28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018Margaret


29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


30ABC30
$ 12.99
5
$ 64.95 02.Apr.2018John


31ABC31
$ 8.51
12
$ 102.12 02.Apr.2018Greg


32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018Margaret


33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


34ABC34
$ 333.45
99
$ 33,011.55 02.Apr.2018John


35ABC35
$ 11.99
1
$ 11.99 02.Apr.2018Greg


36ABC36
$ 741.99
101
$ 74,940.99 02.Apr.2018Margaret


37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018John


39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg


40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018Margaret


41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John


43ABC43
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu




Worksheet: OriginalData

[DocAElstein]

kjlksjklsjg


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Some similar results to the last from previous post
These are from a File supplied by Raghu




S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


1ABC01
$ 55.00
22
$ 1,210.00
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


2ABC02
$ 13.66
7
$ 95.62
15. Mrz 18JT1JT2JT3JT4
15. Mrz 18
16. Mrz 18John


3ABC03
$ 12.99
5
$ 64.95
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


4ABC04
$ 8.51
12
$ 102.12
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


5ABC05
$ 7.22
62
$ 447.64
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


6ABC06
$ 3.99
35
$ 139.65
15. Mrz 18JT1JT2JT3JT4
15. Mrz 18
16. Mrz 18John


7ABC07
$ 333.45
99
$ 33,011.55
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


8ABC08
$ 11.99
1
$ 11.99
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


9ABC09
$ 741.99
101
$ 74,940.99
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


10ABC10
$ 55.00
22
$ 1,210.00
15. Mrz 18JT1JT2JT3JT4
15. Mrz 18
16. Mrz 18John


11ABC11
$ 13.66
7
$ 95.62
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


12ABC12
$ 12.99
5
$ 64.95
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


13ABC13
$ 8.51
12
$ 102.12
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


14ABC14
$ 7.22
62
$ 447.64
15. Mrz 18JT1JT2JT3JT4
15. Mrz 18
16. Mrz 18John


15ABC15
$ 3.99
35
$ 139.65
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


16ABC16
$ 333.45
99
$ 33,011.55
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


17ABC17
$ 11.99
1
$ 11.99
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


18ABC18
$ 741.99
101
$ 74,940.99
15. Mrz 18JT1JT2JT3JT4
16. Mrz 18
16. Mrz 18John


19ABC19
$ 55.00
22
$ 1,210.00
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


20ABC20
$ 13.66
7
$ 95.62
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


21ABC21
$ 12.99
5
$ 64.95
15. Mrz 18Raghu


22ABC22
$ 8.51
12
$ 102.12
15. Mrz 18JT1JT2JT3JT4
16. Mrz 18
16. Mrz 18John


23ABC23
$ 7.22
62
$ 447.64
15. Mrz 18Greg


24ABC24
$ 3.99
35
$ 139.65
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


25ABC25
$ 333.45
99
$ 33,011.55
15. Mrz 18Raghu


26ABC26
$ 11.99
1
$ 11.99
15. Mrz 18John


27ABC27
$ 741.99
101
$ 74,940.99
15. Mrz 18Greg


28ABC28
$ 55.00
22
$ 1,210.00
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


29ABC29
$ 13.66
7
$ 95.62
15. Mrz 18Raghu


30ABC30
$ 12.99
5
$ 64.95
15. Mrz 18John


31ABC31
$ 8.51
12
$ 102.12
15. Mrz 18Greg


32ABC32
$ 7.22
62
$ 447.64
15. Mrz 18Margaret


33ABC33
$ 3.99
35
$ 139.65
15. Mrz 18Raghu


34ABC34
$ 333.45
99
$ 33,011.55
15. Mrz 18John
Worksheet: OriginalData


https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ- (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I)

[DocAElstein]

Bottom part of worksheet shown in last Post
here we see new data added ( rows 47 to 51 ( S No 46 - S no 50 )

Using Excel 2007 32 bit


16ABC16
$ 333.45
99
$ 33,011.55
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


17ABC17
$ 11.99
1
$ 11.99
15. Mrz 18RT1RT2RT3RT4
16. Mrz 18
16. Mrz 18Raghu


18ABC18
$ 741.99
101
$ 74,940.99
15. Mrz 18JT1JT2JT3JT4
16. Mrz 18
16. Mrz 18John


19ABC19
$ 55.00
22
$ 1,210.00
15. Mrz 18GT1GT2GT3GT4
16. Mrz 18
16. Mrz 18Greg


20ABC20
$ 13.66
7
$ 95.62
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


21ABC21
$ 12.99
5
$ 64.95
15. Mrz 18Raghu


22ABC22
$ 8.51
12
$ 102.12
15. Mrz 18JT1JT2JT3JT4
16. Mrz 18
16. Mrz 18John


23ABC23
$ 7.22
62
$ 447.64
15. Mrz 18Greg


24ABC24
$ 3.99
35
$ 139.65
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


25ABC25
$ 333.45
99
$ 33,011.55
15. Mrz 18Raghu


26ABC26
$ 11.99
1
$ 11.99
15. Mrz 18John


27ABC27
$ 741.99
101
$ 74,940.99
15. Mrz 18Greg


28ABC28
$ 55.00
22
$ 1,210.00
15. Mrz 18MT1MT2MT3MT4
16. Mrz 18
16. Mrz 18Margaret


29ABC29
$ 13.66
7
$ 95.62
15. Mrz 18Raghu


30ABC30
$ 12.99
5
$ 64.95
15. Mrz 18John


31ABC31
$ 8.51
12
$ 102.12
15. Mrz 18Greg


32ABC32
$ 7.22
62
$ 447.64
15. Mrz 18Margaret


33ABC33
$ 3.99
35
$ 139.65
15. Mrz 18Raghu


34ABC34
$ 333.45
99
$ 33,011.55
15. Mrz 18John


35ABC35
$ 11.99
1
$ 11.99
15. Mrz 18Greg


36ABC36
$ 741.99
101
$ 74,940.99
15. Mrz 18Margaret


37ABC37
$ 55.00
22
$ 1,210.00
15. Mrz 18Raghu


38ABC38
$ 13.66
7
$ 95.62
15. Mrz 18John


39ABC39
$ 12.99
5
$ 64.95
15. Mrz 18Greg


40ABC40
$ 8.51
12
$ 102.12
15. Mrz 18Margaret


41ABC41
$ 7.22
62
$ 447.64
15. Mrz 18Raghu


42ABC42
$ 3.99
35
$ 139.65
15. Mrz 18John


43ABC43
$ 333.45
99
$ 33,011.55
15. Mrz 18Greg


44ABC44
$ 11.99
1
$ 11.99
15. Mrz 18Margaret


45ABC45
$ 741.99
101
$ 74,940.99
15. Mrz 18Raghu


46ABC46
$ 8.51
12
$ 102.12
16. Mrz 18John


47ABC47
$ 7.22
62
$ 447.64
16. Mrz 18Greg


48ABC48
$ 3.99
35
$ 139.65
16. Mrz 18Margaret


49ABC49
$ 333.45
99
$ 33,011.55
16. Mrz 18Raghu


50ABC50
$ 11.99
1
$ 11.99
16. Mrz 18Raghu


Worksheet: OriginalData

[DocAElstein]

Typical Updated Data File, "Raghu.xlsx" after first consolidation,
with the column L updated appropriately with the consolidation date



Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member


2
1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


3
5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


4
9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


5
13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


6
17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


7
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


8
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


9
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


10
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


11
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


12
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


13
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


14
Worksheet: Tabelle1


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

“zMasterAfter1stConsolidationNewData.xlsm” : https://app.box.com/s/ascky2qg47dzl85b4y7l8sy5qmr3goby




Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

19
18ABC18
$ 741.99
101
$ 74,940.99 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


20
19ABC19
$ 55.00
22
$ 1,210.00 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


21
20ABC20
$ 13.66
7
$ 95.62 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


22
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018Raghu


23
22ABC22
$ 8.51
12
$ 102.12 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


24
23ABC23
$ 7.22
62
$ 447.64 02.Apr.2018Greg


25
24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


26
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


27
26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018John


28
27ABC27
$ 741.99
101
$ 74,940.99 02.Apr.2018Greg


29
28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


30
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


31
30ABC30
$ 12.99
5
$ 64.95 02.Apr.2018John


32
31ABC31
$ 8.51
12
$ 102.12 02.Apr.2018Greg


33
32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018Margaret


34
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


35
34ABC34
$ 333.45
99
$ 33,011.55 02.Apr.2018John


36
35ABC35
$ 11.99
1
$ 11.99 02.Apr.2018Greg


37
36ABC36
$ 741.99
101
$ 74,940.99 02.Apr.2018Margaret


38
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


39
38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018John


40
39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg


41
40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018Margaret


42
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


43
42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John


44
43ABC43
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


45
44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


46
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


47
46ABC46
$ 8.51
12
$ 102.12
John


48
47ABC47
$ 7.22
62
$ 447.64
Greg


49
48ABC48
$ 3.99
35
$ 139.65
Margaret


50
49ABC49
$ 333.45
99
$ 33,011.55
Raghu


51
50ABC50
$ 11.99
1
$ 11.99
Raghu


52
Worksheet: OriginalData

[DocAElstein]

Run Code Sub ExportByName() on data from last post

Results for Updated master Worksheet

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

25
24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


26
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018Raghu


27
26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018John


28
27ABC27
$ 741.99
101
$ 74,940.99 02.Apr.2018Greg


29
28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


30
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018Raghu


31
30ABC30
$ 12.99
5
$ 64.95 02.Apr.2018John


32
31ABC31
$ 8.51
12
$ 102.12 02.Apr.2018Greg


33
32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018Margaret


34
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018Raghu


35
34ABC34
$ 333.45
99
$ 33,011.55 02.Apr.2018John


36
35ABC35
$ 11.99
1
$ 11.99 02.Apr.2018Greg


37
36ABC36
$ 741.99
101
$ 74,940.99 02.Apr.2018Margaret


38
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018Raghu


39
38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018John


40
39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg


41
40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018Margaret


42
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


43
42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John


44
43ABC43
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


45
44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


46
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


47
46ABC46
$ 8.51
12
$ 102.12
02.Apr.2018John


48
47ABC47
$ 7.22
62
$ 447.64
02.Apr.2018Greg


49
48ABC48
$ 3.99
35
$ 139.65
02.Apr.2018Margaret


50
49ABC49
$ 333.45
99
$ 33,011.55
02.Apr.2018Raghu


51
50ABC50
$ 11.99
1
$ 11.99
02.Apr.2018Raghu


52


53


54
Worksheet: OriginalData

[DocAElstein]

Corresponding updated data worksheets for updated master after running Sub ExportByName() for the second time after new data was added

Using Excel 2007 32 bit


41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018Raghu


45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018Raghu


49ABC49$ 333.45
99$ 33,011.5502.Apr.2018Raghu


50ABC50$ 11.99
1$ 11.9902.Apr.2018Raghu


Worksheet: Tabelle1





Using Excel 2007 32 bit


40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018Margaret


44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


48ABC48$ 3.99
35$ 139.6502.Apr.2018Margaret


Worksheet: Tabelle1



Using Excel 2007 32 bit


38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018John


42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John


46ABC46$ 8.51
12$ 102.1202.Apr.2018John




Worksheet: Tabelle1



Using Excel 2007 32 bit


39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg


43ABC43
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


47ABC47$ 7.22
62$ 447.6402.Apr.2018Greg


Worksheet: Tabelle1



https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

Data Files just before second consolidation




15ABC15
$ 3.99
35
$ 139.65 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


19ABC19
$ 55.00
22
$ 1,210.00 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


23ABC23
$ 7.22
62
$ 447.64 02.Apr.2018GT1GT2GT3GT402.Apr.2018Greg


27ABC27
$ 741.99
101
$ 74,940.99 02.Apr.2018GT1GT2GT3GT402.Apr.2018Greg


31ABC31
$ 8.51
12
$ 102.12 02.Apr.2018GT1GT2GT3GT402.Apr.2018Greg


35ABC35
$ 11.99
1
$ 11.99 02.Apr.2018GT1GT2GT3GT402.Apr.2018Greg


39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg
Worksheet: Tabelle1





18ABC18
$ 741.99
101
$ 74,940.99 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


22ABC22
$ 8.51
12
$ 102.12 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018JT1JT2JT3JT402.Apr.2018John


30ABC30
$ 12.99
5
$ 64.95 02.Apr.2018JT1JT2JT3JT402.Apr.2018John


34ABC34
$ 333.45
99
$ 33,011.55 02.Apr.2018JT1JT2JT3JT402.Apr.2018John


38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018JT1JT2JT3JT402.Apr.2018John


42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John
Worksheet: Tabelle1








28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018MT1MT2MT3MT402.Apr.2018Margaret


36ABC36
$ 741.99
101
$ 74,940.99 02.Apr.2018MT1MT2MT3MT402.Apr.2018Margaret


40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018MT1MT2MT3MT402.Apr.2018Margaret


44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret
Worksheet: Tabelle1



Using Excel 2007 32 bit


17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu


21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


49ABC49$ 333.45
99$ 33,011.5502.Apr.2018RT1RT2RT3RT4
02. Apr 18Raghu


50ABC50$ 11.99
1$ 11.9902.Apr.2018Raghu


Worksheet: Tabelle1

[DocAElstein]

Final results for first half of master File after second consolidation

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1
S No
Item
Price
Qty
Total
Distributed
Task1
Task2
Task3
Task4
Completed
Consolidated
Comments
Team Member
Checked


2
1ABC01
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


3
2ABC02
$ 13.66
7
$ 95.62 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


4
3ABC03
$ 12.99
5
$ 64.95 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


5
4ABC04
$ 8.51
12
$ 102.12 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


6
5ABC05
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


7
6ABC06
$ 3.99
35
$ 139.65 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


8
7ABC07
$ 333.45
99
$ 33,011.55 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


9
8ABC08
$ 11.99
1
$ 11.99 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


10
9ABC09
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


11
10ABC10
$ 55.00
22
$ 1,210.00 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


12
11ABC11
$ 13.66
7
$ 95.62 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


13
12ABC12
$ 12.99
5
$ 64.95 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


14
13ABC13
$ 8.51
12
$ 102.12 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


15
14ABC14
$ 7.22
62
$ 447.64 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


16
15ABC15
$ 3.99
35
$ 139.65 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


17
16ABC16
$ 333.45
99
$ 33,011.55 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


18
17ABC17
$ 11.99
1
$ 11.99 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


19
18ABC18
$ 741.99
101
$ 74,940.99 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


20
19ABC19
$ 55.00
22
$ 1,210.00 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


21
20ABC20
$ 13.66
7
$ 95.62 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


22
21ABC21
$ 12.99
5
$ 64.95 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


23
22ABC22
$ 8.51
12
$ 102.12 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


24
23ABC23
$ 7.22
62
$ 447.64 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


25
24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


26
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu
Worksheet: OriginalData

[DocAElstein]

Second half of master worksheet after final second consolidation

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

25
24ABC24
$ 3.99
35
$ 139.65 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


26
25ABC25
$ 333.45
99
$ 33,011.55 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


27
26ABC26
$ 11.99
1
$ 11.99 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


28
27ABC27
$ 741.99
101
$ 74,940.99 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


29
28ABC28
$ 55.00
22
$ 1,210.00 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


30
29ABC29
$ 13.66
7
$ 95.62 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


31
30ABC30
$ 12.99
5
$ 64.95 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


32
31ABC31
$ 8.51
12
$ 102.12 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


33
32ABC32
$ 7.22
62
$ 447.64 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


34
33ABC33
$ 3.99
35
$ 139.65 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


35
34ABC34
$ 333.45
99
$ 33,011.55 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


36
35ABC35
$ 11.99
1
$ 11.99 02.Apr.2018GT1GT2GT3GT402.Apr.201802.Apr.2018Greg


37
36ABC36
$ 741.99
101
$ 74,940.99 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


38
37ABC37
$ 55.00
22
$ 1,210.00 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


39
38ABC38
$ 13.66
7
$ 95.62 02.Apr.2018JT1JT2JT3JT402.Apr.201802.Apr.2018John


40
39ABC39
$ 12.99
5
$ 64.95 02.Apr.2018Greg


41
40ABC40
$ 8.51
12
$ 102.12 02.Apr.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret


42
41ABC41
$ 7.22
62
$ 447.64 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


43
42ABC42
$ 3.99
35
$ 139.65 02.Apr.2018John


44
43ABC43
$ 333.45
99
$ 33,011.55 02.Apr.2018Greg


45
44ABC44
$ 11.99
1
$ 11.99 02.Apr.2018Margaret


46
45ABC45
$ 741.99
101
$ 74,940.99 02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


47
46ABC46
$ 8.51
12
$ 102.12
02.Apr.2018John


48
47ABC47
$ 7.22
62
$ 447.64
02.Apr.2018Greg


49
48ABC48
$ 3.99
35
$ 139.65
02.Apr.2018Margaret


50
49ABC49
$ 333.45
99
$ 33,011.55
02.Apr.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu


51
50ABC50
$ 11.99
1
$ 11.99
02.Apr.2018Raghu


52
Worksheet: OriginalData

[DocAElstein]

hdajshasjh
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code for anwser to this Thread:
http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder/page2




Option Explicit
Sub consolidateToo() ' http://www.excelfox.com/forum/showthread.php/2238-Copy-data-from-Unique-files-into-Masterfile-all-the-files-in-the-same-folder?p=10595#post10595
Rem 1 ThisWorkbook Info
Dim MWs1 As Worksheet: Set MWs1 = ThisWorkbook.Worksheets.Item(1) 'Worksheets("OriginalData")
Dim DtaFName As String: Let DtaFName = VBA.Dir(ThisWorkbook.Path & "\" & "*.xlsx") ' Search criteria set to all Files with .xlsx extension in the same Folder as this workbook, Dir returns first file name that fits criteria
Dim LrMWs1 As Long: Let LrMWs1 = MWs1.Range("A" & MWs1.Rows.Count & "").End(xlUp).Row
Rem 2 main Loop for all data files
Do While DtaFName <> "" ' ==========================================
Workbooks.Open filename:=ThisWorkbook.Path & "\" & DtaFName
Dim WBDta As Workbook: Set WBDta = ActiveWorkbook
Dim WBDtaWs1 As Worksheet: Set WBDtaWs1 = WBDta.Worksheets.Item(1) ' use variable to reference the first worksheet ( counting tabs from the left ) of last opened and therefore active( to be seen ) file
Dim arrIn() As Variant: Let arrIn() = WBDtaWs1.Range("A1").CurrentRegion.Value
'2a) loop for all data rows, copy data from completed rows to master file, ( add date to inputed data array '_-##)
Dim Rw As Long ' --------------------------------
For Rw = 2 To UBound(arrIn(), 1) ' loop through "rows" in data array
If arrIn(Rw, 11) <> Empty And arrIn(Rw, 12) = Empty Then ' Condition for completed work not yet consolidated
Dim arrCsDte(1 To 1, 1 To 7) As String: Let arrCsDte(1, 1) = arrIn(Rw, 7): arrCsDte(1, 2) = arrIn(Rw, 8): arrCsDte(1, 3) = arrIn(Rw, 9): arrCsDte(1, 4) = arrIn(Rw, 10): arrCsDte(1, 5) = arrIn(Rw, 11): arrCsDte(1, 6) = Format(Date, "dd.mmm.yyyy"): arrCsDte(1, 7) = arrIn(Rw, 13) ' 7 "columns" of data to be added to master file
MWs1.Range("A2:A" & LrMWs1 & "").Find(what:=arrIn(Rw, 1), After:=MWs1.Range("A2"), LookIn:=xlValues, Lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext).Offset(0, 6).Resize(1, 7) = arrCsDte() ' We look down the first column in the master file to find the cell comtaining the S No We apply the offest property to thast cell to get across to column G and then the resize property gives us the range of 7 columns to which we may apply the values in the array filled for the row data
Let arrIn(Rw, 12) = arrCsDte(1, 6) '(Put the current date in the array made from data range '_-##)
Else ' Datá row is completed and consolidated , so nothing to do for this row
End If
Next Rw ' End loop for all data rows --------
'2b) Update and close current data workbook
Let WBDtaWs1.Range("A1").Resize(UBound(arrIn(), 1), UBound(arrIn(), 2)).Value = arrIn() ' reassign the values from the input data array back to the range as this now has the consolidated date in it
WBDta.Close savechanges:=True
'2c Serch for next data file name
Let DtaFName = VBA.Dir() ' Unqualified Dir returns next found file with previos search criteria, but only returns each file name once
Loop ' Do While DtaFName <> "" again ==============================
End Sub

[DocAElstein]

Some sample data for other Posts and Threads:
http://www.eileenslounge.com/viewtopic.php?f=30&t=29652
Using this code:

Sub Its() ' snb 2017
Dim It As Variant
For Each It In ThisWorkbook.VBProject.References
Dim strIts As String
Let strIts = strIts & "Description:" & vbTab & It.Description & vbCr & "Name:" & vbTab & vbTab & It.Name & vbCr & "Buitin:" & vbTab & vbTab & It.BuiltIn & vbCr & "Minor:" & vbTab & vbTab & It.minor & vbCr & "Major:" & vbTab & vbTab & It.major & vbCr & "FullPath:" & vbTab & vbTab & It.fullpath & vbCr & "GUID:" & vbTab & vbTab & It.GUID & vbCr & "Type:" & vbTab & vbTab & It.Type & vbCr & "Isbroken:" & vbTab & vbTab & It.isbroken & vbCr & vbCr
Next It
Debug.Print strIts ' From VB Editor Ctrl+g to get Immediate Window from which info can be copied
End Sub
Here some results. ( If anyone passing has other Excel versions and would like to pass on what the code above gives, then that would be nice, thanks :) )

Excel 2007

Description: Visual Basic For Applications
Name: VBA
Buitin: Wahr
Minor: 0
Major: 4
FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
GUID: {000204EF-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Excel 12.0 Object Library
Name: Excel
Buitin: Wahr
Minor: 6
Major: 1
FullPath: C:\Program Files\Microsoft Office\Office12\EXCEL.EXE
GUID: {00020813-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: OLE Automation
Name: stdole
Buitin: Falsch
Minor: 0
Major: 2
FullPath: C:\Windows\system32\stdole2.tlb
GUID: {00020430-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Office 12.0 Object Library
Name: Office
Buitin: Falsch
Minor: 4
Major: 2
FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE12\MSO.DLL
GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}
Type: 0
Isbroken: Falsch

Description: Microsoft Word 12.0 Object Library
Name: Word
Buitin: Falsch
Minor: 4
Major: 8
FullPath: C:\Program Files\Microsoft Office\Office12\MSWORD.OLB
GUID: {00020905-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch


Excel 2003

Description: Visual Basic For Applications
Name: VBA
Buitin: Wahr
Minor: 0
Major: 4
FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
GUID: {000204EF-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Excel 11.0 Object Library
Name: Excel
Buitin: Wahr
Minor: 5
Major: 1
FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
GUID: {00020813-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: OLE Automation
Name: stdole
Buitin: Falsch
Minor: 0
Major: 2
FullPath: C:\Windows\system32\stdole2.tlb
GUID: {00020430-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Office 11.0 Object Library
Name: Office
Buitin: Falsch
Minor: 3
Major: 2
FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}
Type: 0
Isbroken: Falsch

Description: Microsoft Word 12.0 Object Library
Name: Word
Buitin: Falsch
Minor: 4
Major: 8
FullPath: C:\Program Files\Microsoft Office\Office12\MSWORD.OLB
GUID: {00020905-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch





Excel 2010

Description: Visual Basic For Applications
Name: VBA
Buitin: Wahr
Minor: 1
Major: 4
FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
GUID: {000204EF-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Excel 14.0 Object Library
Name: Excel
Buitin: Wahr
Minor: 7
Major: 1
FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
GUID: {00020813-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: OLE Automation
Name: stdole
Buitin: Falsch
Minor: 0
Major: 2
FullPath: C:\Windows\SysWOW64\stdole2.tlb
GUID: {00020430-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

Description: Microsoft Office 14.0 Object Library
Name: Office
Buitin: Falsch
Minor: 5
Major: 2
FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}
Type: 0
Isbroken: Falsch

Description: Microsoft Word 14.0 Object Library
Name: Word
Buitin: Falsch
Minor: 5
Major: 8
FullPath: C:\Program Files (x86)\Microsoft Office\Office14\MSWORD.OLB
GUID: {00020905-0000-0000-C000-000000000046}
Type: 0
Isbroken: Falsch

[DocAElstein]

To support solution to this Thread:
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email


Test data supplied by Thainguyen for this Thread :
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email




Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
N

1Equipment PM







2
Machine EQ.ID
Manufacture
Model
Description
Serial Number
Weekly
Date of Service
Weekly
Next Service
Monthly
Date of Service
Monthly
Next Service
Quarterly
Date of Service
Quarterly
Next Service
Softwear


3







4
1JUKIGKG GLGL SCREEN PRINTERA123
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


5
2JUKIKE-1070LSMT Placement MachineA124
11.04.2018
18.04.2018
28.03.2018
25.04.2018
N/A
N/A


6
9ACE ProductionKISS-101BSelective Wave SolderA125
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


7
59Heller1826 MK5Reflow OvenA126
N/A
N/A
16.03.2018
13.04.2018
N/A
N/A


8
62Exit Sign -- N/A -- Exit LightsN/AN/AA127
N/A
N/A
N/A
N/A
N/A
N/A


9
69South-Tek System N2-Gen 35STNitrogen GeneratorA128
10.04.2018
17.04.2018
N/A
N/A
09.03.2018
06.04.2018


10
75ACE ProductionKISS-102Selective Wave SolderA129
16.04.2018
23.04.2018
N/A
N/A
N/A
N/A


11
101FKN systemN100 NibblerDispensingA130
N/A
N/A
N/A
N/A
04.04.2018
02.05.2018


12
109MycronicMY200sxSMT MachineA131
N/A
N/A
N/A
N/A
N/A
N/A


13
112X-TEKXTV-160X-Ray SystemA132
N/A
N/A
N/A
N/A
N/A
N/A


14
113MIRTECMV-6 OMNIAOIA133
N/A
N/A
N/A
N/A
N/A
N/A


15
116JUKIKE-2060RLSMT Placement MachineA134
N/A
N/A
N/A
N/A
N/A
N/A


16
127ELGIEG22-150Air CompressorA135
N/A
N/A
N/A
N/A
N/A
N/A


17
128JukiKE-2050SMTA136
N/A
N/A
N/A
N/A
N/A
N/A


18
137JukiK3Screen printerA137
06.04.2018
13.04.2018
N/A
N/A
N/A
N/A


19
141Heller1826 MK5Reflow OvenA138
N/A
N/A
N/A
N/A
N/A
N/A


20
142NISSANMCU-112A331.VForkliftA139
N/A
N/A
N/A
N/A
15.02.2018
15.03.2018


21
142NISSAN/yearly oil change and lubeMCU-112A331.VForkliftA140
N/A
N/A
N/A
N/A
N/A
N/A


22





28.01.1900


23





Worksheet: Equipment PM

[DocAElstein]

Another view of last table

( for Thread: http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email )

Using Excel 2007 32 bit

Equipment PM







Machine EQ.ID
Manufacture
Model
Description
Serial Number
Weekly
Date of Service
Weekly
Next Service
Monthly
Date of Service
Monthly
Next Service
Quarterly
Date of Service
Quarterly
Next Service









1JUKIGKG GLGL SCREEN PRINTERA123
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


2JUKIKE-1070LSMT Placement MachineA124
11.04.2018
18.04.2018
28.03.2018
25.04.2018
N/A
N/A


9ACE ProductionKISS-101BSelective Wave SolderA125
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


59Heller1826 MK5Reflow OvenA126
N/A
N/A
16.03.2018
13.04.2018
N/A
N/A


62Exit Sign -- N/A -- Exit LightsN/AN/AA127
N/A
N/A
N/A
N/A
N/A
N/A


69South-Tek System N2-Gen 35STNitrogen GeneratorA128
10.04.2018
17.04.2018
N/A
N/A
09.03.2018
06.04.2018


75ACE ProductionKISS-102Selective Wave SolderA129
16.04.2018
23.04.2018
N/A
N/A
N/A
N/A


101FKN systemN100 NibblerDispensingA130
N/A
N/A
N/A
N/A
04.04.2018
02.05.2018


109MycronicMY200sxSMT MachineA131
N/A
N/A
N/A
N/A
N/A
N/A


112X-TEKXTV-160X-Ray SystemA132
N/A
N/A
N/A
N/A
N/A
N/A


113MIRTECMV-6 OMNIAOIA133
N/A
N/A
N/A
N/A
N/A
N/A


116JUKIKE-2060RLSMT Placement MachineA134
N/A
N/A
N/A
N/A
N/A
N/A


127ELGIEG22-150Air CompressorA135
N/A
N/A
N/A
N/A
N/A
N/A


128JukiKE-2050SMTA136
N/A
N/A
N/A
N/A
N/A
N/A


137JukiK3Screen printerA137
06.04.2018
13.04.2018
N/A
N/A
N/A
N/A


141Heller1826 MK5Reflow OvenA138
N/A
N/A
N/A
N/A
N/A
N/A


142NISSANMCU-112A331.VForkliftA139
N/A
N/A
N/A
N/A
15.02.2018
15.03.2018


142NISSAN/yearly oil change and lubeMCU-112A331.VForkliftA140
N/A
N/A
N/A
N/A
N/A
N/A







28.01.1900
Worksheet: Equipment PM

[DocAElstein]

Table from above again
Using Excel 2007 32 bit
Row\Col
F
G
H
I
J
K

1







2
Weekly
Date of Service
Weekly
Next Service
Monthly
Date of Service
Monthly
Next Service
Quarterly
Date of Service
Quarterly
Next Service


3







4
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


5
11.04.2018
18.04.2018
28.03.2018
25.04.2018
N/A
N/A


6
06.04.2018
13.04.2018
15.03.2018
12.04.2018
N/A
N/A


7
N/A
N/A
16.03.2018
13.04.2018
N/A
N/A


8
N/A
N/A
N/A
N/A
N/A
N/A


9
10.04.2018
17.04.2018
N/A
N/A
09.03.2018
06.04.2018


10
16.04.2018
23.04.2018
N/A
N/A
N/A
N/A


11
N/A
N/A
N/A
N/A
04.04.2018
02.05.2018


12
N/A
N/A
N/A
N/A
N/A
N/A


13
N/A
N/A
N/A
N/A
N/A
N/A


14
N/A
N/A
N/A
N/A
N/A
N/A


15
N/A
N/A
N/A
N/A
N/A
N/A


16
N/A
N/A
N/A
N/A
N/A
N/A


17
N/A
N/A
N/A
N/A
N/A
N/A


18
06.04.2018
13.04.2018
N/A
N/A
N/A
N/A


19
N/A
N/A
N/A
N/A
N/A
N/A


20
N/A
N/A
N/A
N/A
15.02.2018
15.03.2018


21
N/A
N/A
N/A
N/A
N/A
N/A


22





28.01.1900
Worksheet: Equipment PM

[DocAElstein]

Code for this Thread:
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email



Option Explicit
Private Sub Workbook_Open()
Rem 1 Worksheets Info.
Dim Ws As Worksheet: Set Ws = ThisWorkbook.Worksheets("Equipment PM")
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row
Rem 2 data range
Dim arrIn() As Variant: Let arrIn() = Ws.Range("A1:K" & Lr & "").Value2
Rem 3 Todays date as Double(Long) number
Dim TdyDbl As Long: Let TdyDbl = CLng(Now()) ' like 43233 for 13 May 2018
Let TdyDbl = CLng(DateSerial(2018, 3, 15)) - 3 ' To test only #####
Rem 4 Rows for due date for next service for weekly(G), Monthly(I), and Quarterly(K). Code to pick up the date from these columns and automatic send email notification 3 days before the due date.
'4a) determine rows as string or those row numbers
Dim Rw As Long
For Rw = 4 To Lr Step 1
If arrIn(Rw, 7) = TdyDbl + 3 Or arrIn(Rw, 9) = TdyDbl + 3 Or arrIn(Rw, 11) = TdyDbl + 3 Then
Dim strRws As String 'String of rows for criteria met in G Or I Or K
Let strRws = strRws & " " & Rw
Else ' No "3 days before due service date" criteria met for this row
End If
Next Rw
If strRws = "" Then Exit Sub ' case no criteria met for the day this workbook was opened.
Let strRws = VBA.Strings.Mid$(strRws, 2) ' take off first space
'4b) Array of rows
Dim arrRws() As String: Let arrRws() = VBA.Strings.Split(strRws, " ", -1, vbBinaryCompare)
Rem 5 HTML Table of required output '
Dim ProTble As String
'5a) Table start
Let ProTble = _
"<table width=520>" & vbCrLf & _
"<col width=30>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=150>" & vbCrLf & _
"<col width=40>" & vbCrLf & vbCrLf
'5b) data rows
Dim iCnt As Long, jCntStear As Variant, jCnt As Long ' data "columns" , "rows"
For Each jCntStear In arrRws() ' To Loop for all rows meeting criteria
Let jCnt = jCnt + 1 ' Rows count for table to send
Dim LisRoe As String
Let LisRoe = LisRoe & "<tr height=16>" & vbCrLf
For iCnt = 1 To 5
Let LisRoe = LisRoe & "<td>" & arrIn(arrRws(jCnt - 1), iCnt) & "</td>" & vbCrLf ' -1 is because Split Function returns array of string types in 1 Dimensional array starting at indice 0, so our jCnt is one too big
Next iCnt
Let LisRoe = LisRoe & "</tr>" & vbCrLf & vbCrLf
Let ProTble = ProTble & LisRoe
Let LisRoe = ""
Next jCntStear
Let ProTble = ProTble & "</table>" ' table end
Debug.Print ProTble
Rem 6 EMail send 'For info see: http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
.Configuration(LCD_CW & "smtpusessl") = True '
.Configuration(LCD_CW & "smtpauthenticate") = 1 '
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de"
' 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 ' 465 or 25 for t-online.de 'or 587 'or 25
'

.Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
.Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
' Optional - How long to try
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
' Intraction protocol is Set/ Updated
.Configuration.Fields.Update '
'End With ' ---------------------- my Created LCDCW Library
'With ' --- ' Data to be sent------ my Created LCDCW Library
Dim strHTML As String: Let strHTML = ProTble 'ProTble(rngArr()) ' Let strHTML = RangetoHTML(rng)
' Dim Highway1 As Long: Let Highway1 = FreeFile(0) '
' Open ThisWorkbook.Path & "" & "jawaharse.txt" For Output As #Highway1 '
' Print #Highway1, strHTML
' Close #Highway1
.To = "Doc.AElstein@t-online.de" '
.cc = ""
.BCC = ""
.from = """Equipment- Maint Records.xlsm"" <YourEMailAddresseOrAnyCrap>"
.Subject = Ws.Range("A1").Value
.HTMLBody = strHTML
' .AddAttachment ThisWorkbook.Path & "\jawaharse.txt"
.Send ' Do it
End With ' CreateObject("CDO.Message") -----my Created LCDCW Library
End Sub



https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

To support this Thread
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email?p=10679#post10679

Re post code in Code tags, Like ....

Please use CODE TAGS if you are writing codes in your post.

To use code tags,
either
select your entire code and press the code tag button # in the editor below,
or
simply type your code as below


Your Code Here



Your Code Here







Private Sub cmdNot_Click()

Dim OutApp As Object
Dim OutMail As Object

…………………….

……………..

End Sub





BBCodeCodeTags.JPG : https://imgur.com/4HunNcs
2060

_.__________________

If you post using Code tags, then it will come out in the final post in a Code Window, like this:

Private Sub cmdNot_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim fileName As String
Dim mSubject As String
Dim signature As String
Dim fname As String
Dim mBody As String
Dim rng As Range
Dim rng1 As Range
Dim ws As Worksheet
Dim mailTo As String
Set ws = Sheets("MRO")
fname = ws.Range("B4")
mSubject = "MRO " & " For " & Range("C6").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'mBody = "2-SO\Material Request Form .xlsm"

Dim Path As String

mBody = "<font size=""3"" face=""Calibri"">" & _
"Dear Team,<br><br>" & _
"Please open the file from below link and put your signature on the respective cell after you completed your task.<br><B>" & _
fileName & ".xlsm" & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & Path & fileName & ".xlsm" & _
""">Files are saved here</A>" & "-->" & Range("C6").Value & _
"<br><br>Best Regards," & _
"<br><br></font>"

With OutMail
.display
End With
signature = OutMail.body
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

With OutMail
'.To = "email"
.To = ""
.CC = ""
.BCC = ""
.Subject = mSubject
'.body = "Dear Team," & vbCrLf & vbCrLf & "Please open the file from below link and put your signature on the respective cell and save the sheet"
'.htmlbody = RangetoHTML(rng)
.htmlbody = mBody
'.Attachments.Add fileName
.display
End With
'ws.PageSetup.RightHeader = "&""Calibri,italic""&11& " & ws.Range("A1")
ActiveWorkbook.Close False
ActiveWorkbook.Close
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

[DocAElstein]

Code in code tags from here:
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email?p=10699#post10699


Dim OutApp As Object
Dim OutMail As Object
Dim fileName As String
Dim mSubject As String
Dim signature As String
Dim fname As String
Dim mBody As String
Dim rng As Range
Dim rng1 As Range
Dim ws As Worksheet
Dim mailTo As String
fname = ws.Range("A1")
mSubject = "Equipment" & " For " & Range("A1").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'mBody = "Z:\2\Form\\Manufacturing Order.xlsm"

Dim Path As String
ws.Protect ("Equipment")
Path = "\\Equipment- Maint RecordsThai1.xlsm"
mBody = "<font size=""3"" face=""Calibri"">" & _
"Dear Team,<br><br>" & _
"Please open the file from below link and change the date on the respective cell after you completed your task.<br><B>" & _
fileName & ".xlsm" & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & Path & fileName & ".xlsm" & _
""">Files are saved here</A>" & "-->" & Range("A1").Value & _
"<br><br>Best Regards," & _
"<br><br></font>"

With OutMail
.display
End With
signature = OutMail.body
With Application
.EnableEvents = False
.ScreenUpdating = False
End With







Private Sub cmdNot_Click()
If Application.UserName = "Thai Nguyen" Then
Dim ws As Worksheet: Set ws = Sheets("Name")
Dim rng As Range, rng1 As Range
Dim fileName As String, fname As String
Let fname = ws.Range("B4")
Let mSubject = "Name"
Dim OutApp As Object, OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim Subject As String, signature As String, mBody As String, mailTo As String
'mBody = "copy you link path in here"
Let mBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Team,<br><br>" & _
"Please open the file from below link and put your signature on the respective cell after you completed your task.<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & """>Link to the file</A>" & _
"<br><br>Regards," & _
"<br><br>Thai Nguyen</font> "
OutMail.display
Let signature = OutMail.body
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With OutMail
'.To = "email"
If ws.Range("EU16") = True Then
Let mailTo = mailTo + "Thai Nguyen;"
Else
End If
If ws.Range("EU17") = True Then
mailTo = mailTo + "email"
End If
If ws.Range("EU18") = True Then
Let mailTo = mailTo + "email"
End If
If ws.Range("EU19") = True Then
Let mailTo = mailTo + "email"
End If
.To = mailTo
.CC = "Thai Nguyen"
.BCC = ""
.Subject = mSubject
'.body = "Hi Team," & vbCrLf & vbCrLf & "Please open the file from below link and put your signature on the respective cell and save the sheet"
'.htmlbody = RangetoHTML(rng)
.htmlbody = mBody
'.Attachments.Add fileName
.display
End With
'ws.PageSetup.RightHeader = "&""Calibri,italic""&11& " & ws.Range("A1")
ws.Protect ("Name")
ActiveWorkbook.Save
ActiveWorkbook.Close
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Else
MsgBox "You are not authorised to send BOM form, please check with BOM owner"
End If
End Sub

[DocAElstein]

Share account for testing file access from a hyperlink in a received EMail
In support of a possible solution to this post in this Thread:
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email?p=10724#post10724

It is required to have a simple hyperlink to an Excel File appear in the received Email sent to members of a team.
I am not sure currently how to get a link directly to the File.

An second alternative involves storing the file at a File sharing site and using the link to the file as the URL part of a hyperlink.

This post discusses the setting up of such an account to allow storing of, and sharing via a supplied link to, the file.

As an example of a file sharing site we consider the free version of box.net
Some googling my be needed to finally get at the free version which may go under the name of “free” , “Individual rate”, “Personal free”
Currently you need to find your way to the free 10GB offer. This is currently at this link:
https://account.box.com/signup/n/personal#fbms6
Free10GB box net account register.JPG : https://imgur.com/NB3GThi
Note , by registering, you can choose a language to suit you.
Free10GB Select language .JPG : : https://imgur.com/aNzW1kq
( You can change the language to a different one after registering also
Free10GB Change language .JPG : https://imgur.com/IosqbAI )


For this registering , I use the created gmail account used for experiments in the current thread which this post supports, excellearning12@gmail.com ( excelfox Thread : http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email )

The password I pass on privately to those needing
Free10GB box net account register 2.JPG : https://imgur.com/Y2pLogO
Free10GB box net account register 3.JPG : https://imgur.com/QhCR8fP
Free10GB box net account register Verify Email 4.JPG : https://imgur.com/ffG7erw

Various steps are then gone through, they may be slightly different to the following:

At some point you should you should see the possibility to upload a file, following steps similar to these:
Free10GB box net 5 .JPG : https://imgur.com/lNWvQwF
To upload a file and get a URL link to use in a hyperlink to it:
Upload Files:
Free10GB box net 6 .JPG : https://imgur.com/rTU1Xbk
Select a file:
Free10GB box net 7 .JPG : https://imgur.com/wKKlqoO
Select share to obtain a URL link to the file :
Free10GB box net 8 .JPG : https://imgur.com/R3VbyhR
Copy link to be used in Hyperlink :
Free10GB box net 9 .JPG : https://imgur.com/8yaYwaK

[DocAElstein]

Testing codes in support of this Thread
http://www.excelfox.com/forum/showthread.php/2253-Automatic-sort-due-date-and-send-email?p=10727#post10727







https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code for Thai .


Option Explicit
Sub Sendfromexcellearninggmail()
Rem 6 EMail send 'For info see: http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
'6a(i)
With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
.Configuration(LCD_CW & "smtpusessl") = True '
.Configuration(LCD_CW & "smtpauthenticate") = 1 '
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "smtp.office365.com" ' "smtp.live.com" ' "smtp-mail.outlook.com" ' "smtp.live.com" ' "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de"
' 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") = 465 ' 465 or 25 for gmail '587 ' 25 ' 465 or 25 for t-online.de 'or 587 'or 25
'
.Configuration(LCD_CW & "sendusername") = "excellearning12@gmail.com" '
.Configuration(LCD_CW & "sendpassword") = "xxxxxxxxxxxxx" ' '
' .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
' .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
' Optional - How long to try
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
' Intraction protocol is Set/ Updated
.Configuration.Fields.Update '
'End With 6a(i)' ---------------------- my Created LCDCW Library
'6a(ii) With ' -- ' Data to be sent--- my Created LCDCW Library
Dim strHTML As String: Let strHTML = "<font size=""3"" face=""Calibri"">" & _
"This is sent from EMail account:" & _
"<br>Username: ""excellearning12@gmail.com""" & _
"<br>Password: ""xxxxxxxxxxxxx""" & _
"<br><br>" & _
"<br>Please click on the 5 links below and tell me what happens, thanks!" & _
"<br>1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
"<br>2 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
"<br>3 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received EMail.htm"""">htm file on your computer</A>" & _
"<br>4 <A HREF=""file://" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>" & _
"<br>5 <A HREF=""file:///" & ThisWorkbook.Path & "\" & "Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls"""">empty xls file on your computer</A>"
.To = "THai xxxxxxxxx"
'.CC = "xxxxxxxxxxxxx"
.BCC = ""
.from = """excellearning12@gmail.com"" <excellearning12@gmail.com>"
.Subject = "Sent from EMail address: excellearning12@gmail.com"
.htmlbody = strHTML

.Send ' Do it
End With ' 6a(ii) CreateObject("CDO.Message") ---my Created LCDCW Library
End Sub

Testing files( sent privately ) :
I have also posted 3 files to you using our share g mail account , ExcelVBAExp@gmail.com
Please can you also try out the test…

Please do the following.

_1) Download all three files , and important: All must be stored in the same Folder.
( the three files are:
Test file DOThtm to be stored on your computer to try to open with a Hyperlink in a received Email.htm
Empty test file DOTxls stored on your computer to try to open from Hyperlink in arrived Email.xls
Test File Thai to send EMail containing Hyperlinks to Files.xlsm )

_2) Open only file Test File Thai to send EMail containing Hyperlinks to Files.xlsm
Run code Sub Sendfromexcellearninggmail()

You should receive an Email similar to these:
Alan 5 Links in German Telekom.JPG : https://imgur.com/LeASbhf
2079
Alan 5 Links in gmail.JPG : https://imgur.com/0sdyZEj
2080

_3) Please click on the links.

_4) Please reply and tell me what happens when you click each link

Thanks
Alan

[DocAElstein]

First test code for solution to this thread:
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs

( Run code Sub TestieCalls() )



Option Explicit
Sub TestieCalls()
Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testie(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("A1:B" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("A1:B" & lr2 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String
'2a size arrays to that of sheet 2 data
ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
'2b fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
Next Cnt
Rem 3 main loop ' == Start main loop ==========
For Cnt = 1 To UBound(arrSht2(), 1) - 1 Step 1 ' Counting at each row
Dim DifCnt As Long 'Count of different cells
' Condition check
If (arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) = arrSht1b(Cnt + 1, 1) And arrSht2(Cnt + 1, 2) = arrSht1b(Cnt + 1, 2)) Then ' condition for changed row but next row is as previous : row had data changed, but a row was not inserted
Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2) 'change any changed cell
If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & " <> " & arrSht1(Cnt, 1)
Let DifCnt = DifCnt + 1
Else: End If
If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & " <> " & arrSht1(Cnt, 2)
Let DifCnt = DifCnt + 1
Else: End If
' Condition check
ElseIf ((arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) <> arrSht1b(Cnt + 1, 1) Or arrSht2(Cnt + 1, 2) <> arrSht1b(Cnt + 1, 2))) Then ' main condition suggesting added new row
Dim AdedRows As Long: Let AdedRows = AdedRows + 1
'3b we need to shift all data down to allow space for new row in arrSht2()
Dim CntIn As Long
For CntIn = (UBound(arrSht2(), 1) - 1) To Cnt Step -1 'loop for all but last from this row
Let arrSht1b(CntIn + 1, 1) = arrSht1b(CntIn, 1): arrSht1b(CntIn + 1, 2) = arrSht1b(CntIn, 2) ' This effectively pulls up each row by one
Next CntIn
'3c add the new data to the modified array, Let arrSht1b()
Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2)
If arrSht1b(Cnt, 1) = "" Then arrSht1b(Cnt, 1) = " " ' Just to make final output more neat
If arrSht1b(Cnt, 2) = "" Then arrSht1b(Cnt, 2) = " "
'3d add info to the output array
If Cnt > UBound(arrSht1(), 1) Then ' case of new lines
Let arrOut(Cnt, 1) = "An new extra line contains " & arrSht1b(Cnt, 1): arrOut(Cnt, 2) = "An new extra line contains " & arrSht1b(Cnt, 2)

Else
If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & " <> " & arrSht1(Cnt, 1)
Let DifCnt = DifCnt + 1
Else: End If
If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & " <> " & arrSht1(Cnt, 2)
Let DifCnt = DifCnt + 1
Else: End If
End If
'
Let Cnt = Cnt + 1 ' we need to skip the next row as that was just effectively added so we are done with it
Else ' row has not been added here

End If
Next Cnt ' ========= End main loop ==========
Rem 4 last row may be new
If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Or arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then ' either cell in last row is different
If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Then
Let arrOut(lr2, 1) = arrSht2(lr2, 1) & " on last row is new"
Let DifCnt = DifCnt + 1
Else: End If
If arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then
Let arrOut(lr2, 2) = arrSht2(lr2, 2) & " on last row is new"
Let DifCnt = DifCnt + 1
Else: End If
Else 'last row on sheet2 is as on sheet1
End If
Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Tabelle3")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:B1").Value = "Sheet1": Ws3.Range("C1:D1").Value = "Test Output": Ws3.Range("E1:F1").Value = "Sheet2"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("C2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Ws3.Range("E2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBoox output
MsgBox Prompt:="inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub






https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Test runs from code [Code]Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)





https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code in support of this Post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741


Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
Call Testy(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testy(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("A1:B" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("A1:B" & lr2 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrSht1Chk(1 To UBound(arrSht1(), 1)): ReDim arrSht2Chk(1 To UBound(arrSht2(), 1)) ' Arrays for concatenated data
'2b make check arrays fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
' Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
Next Cnt
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
Next Cnt
'2c make contents of array for output initially all dat from Sheet2
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2))
Next Cnt
Rem 3 main loop ' == Start Main loop ================
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of Sheet2
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
'3a action whilst match is found --Inner Loop------
Do While Not IsError(MtchRes) ' The 3a Loop
Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
If DupyCnt > 1 Then
Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 1): arrOut(MtchRes, 2) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 2)
Else
Let arrOut(MtchRes, 1) = "": arrOut(MtchRes, 2) = "" ' remove the found data from array for output so that next line can look again for a possible duplicate
End If
Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
Loop ' ----------------------------------------
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Sheet1
Next Cnt ' ========= End main loop ================= effectively we go to next row of data in Sheet1 with this line

Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Tabelle3")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:B1").Value = "Sheet1": Ws3.Range("C1:D1").Value = "Test Output": Ws3.Range("E1:F1").Value = "Sheet2"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("C2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Ws3.Range("E2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub

[DocAElstein]

Code in support of this Post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10745#post10745



Option Explicit
Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
Call Testy(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testy(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("A1:B" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("A1:B" & lr2 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String, arrSht2ChkKopie() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrSht1Chk(1 To UBound(arrSht1(), 1))
ReDim arrSht2Chk(1 To UBound(arrSht2(), 1))
ReDim arrSht2ChkKopie(1 To UBound(arrSht2(), 1))
'2b make check arrays fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
' Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
Next Cnt
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
Next Cnt
Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned too eachother
'2c make contents of array for output initially all dat from Sheet2
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2))
Next Cnt
Rem 3 main loop ' == Start Main loop ================
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of Sheet2
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
' If IsError(MtchRes) Then ' case data is missing Sheet2 ( deleted ) ' This straight forward modification to the existing code will not work. This is because the code modifies the check array , arrSht2Chk() , when checking for the data from sheet1 in sheet2
' Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "Missing: " & arrSht1(Cnt, 2)
' Else:
'3a(ii) action whilst match is found --Inner Loop------
Do While Not IsError(MtchRes) ' The 3a Loop
Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
If DupyCnt > 1 Then
Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 1): arrOut(MtchRes, 2) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 2)
Else
Let arrOut(MtchRes, 1) = "": arrOut(MtchRes, 2) = "" ' remove the found data from array for output so that next line can look again for a possible duplicate
End If
Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
Loop ' ----------------------------------------
' End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Sheet1
Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Sheet1 with this line
Rem 3b Second Loop ' ##### Start Second loop #####
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of Sheet2
'Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
If IsError(MtchRes) Then ' case data is missing Sheet2 ( deleted )
Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "Missing: " & arrSht1(Cnt, 2)
Else
End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Sheet1
Next Cnt ' ##### End Second Loop ################# effectively we go to next row of data in Sheet1 with this line


Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Tabelle3")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:B1").Value = "Sheet1": Ws3.Range("C1:D1").Value = "Test Output": Ws3.Range("E1:F1").Value = "Sheet2"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("C2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Ws3.Range("E2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code in support of this Post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10745#post10745




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

1Sheet1Sheet1Test OutputTest OutputSheet2Sheet2


2Customer Assembly Customer Assembly


3Nu Torque
13456Nu Torque
13456


4Blu OriginSpaceshipAlaska
789


5Jet Blue21ABCExcel123HiThaiExcel123HiThai


6Alaska
789Blu OriginSpaceship


7ToyotaSupraMissing: ToyotaMissing: SupraEmirateABC12345


8EmirateABC12345Jet Blue21ABC


9
Worksheet: Tabelle3


https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

Results in support of answer to this post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10749#post10749
( note a typo in your data for row 9 ( correspondingly output row 10 in these screenshots) : Angle is not Angel . hence this is taken by my code as Missing data row )

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1OriginalOriginalOriginalOriginalOriginalOriginalT est OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW


2Assembly #:Assembly Name: Assembly Name: Assembly #:Assembly Name:


3Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


4
1Nu Torque
13456
456
45613456456456
1Nu Torque
13456
456
456


5
1Blu OriginSpaceship
457
457Spaceship457457
1Blu OriginSpaceship
457
457


6
2Jet Blue21ABC
458
458ABC458458
2Jet Blue21ABC
458
458


7
3EXCELL123
123ABCABCMISSING: 3MISSING: EXCELL123MISSING: 123MISSING: ABCMISSING: ABC
3Alaska
789
459
459


8
3ToyotaSupra
460
460Supra460460
3ToyotaSupra
460
460


9
2EmirateABC12345
461
461ABC12345461461
2EmirateABC12345
461
461


10
1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
1AngleABC12346
462
462
Worksheet: Result



Using Excel 2007 32 bit

OriginalOriginalOriginalOriginalOriginalOriginalTe st OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW

Assembly #:Assembly Name: Assembly Name: Assembly #:Assembly Name:

Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


1Nu Torque
13456
456
45613456456456
1Nu Torque
13456
456
456


1Blu OriginSpaceship
457
457Spaceship457457
1Blu OriginSpaceship
457
457


2Jet Blue21ABC
458
458ABC458458
2Jet Blue21ABC
458
458


3EXCELL123
123ABCABCMISSING: 3MISSING: EXCELL123MISSING: 123MISSING: ABCMISSING: ABC
3Alaska
789
459
459


3ToyotaSupra
460
460Supra460460
3ToyotaSupra
460
460


2EmirateABC12345
461
461ABC12345461461
2EmirateABC12345
461
461


1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
1AngleABC12346
462
462
Worksheet: Result

[DocAElstein]

Code corresponding to last post, in support of answer to this post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10749#post10749



Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Original"), Worksheets("NEW"))
' Call Testy(Worksheets("Original"), Worksheets("NEW"))
Call Testies(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Testies(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("B1:G" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("B1:G" & Lr1 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String, arrSht2ChkKopie() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2) - 1) ' -1 as one column , D is not required
ReDim arrSht1Chk(1 To UBound(arrSht1(), 1))
ReDim arrSht2Chk(1 To UBound(arrSht2(), 1))
ReDim arrSht2ChkKopie(1 To UBound(arrSht2(), 1))
'2b make check arrays fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
' Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
' Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2) & "|" & arrSht1(Cnt, 4) & "|" & arrSht1(Cnt, 5) & "|" & arrSht1(Cnt, 6)
Next Cnt
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
' Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2) & "|" & arrSht2(Cnt, 4) & "|" & arrSht2(Cnt, 5) & "|" & arrSht2(Cnt, 6)
Next Cnt
Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned too eachother
'2c make contents of array for output initially all dat from NEW
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2)): arrOut(Cnt, 3) = CStr(arrSht2(Cnt, 4)):: arrOut(Cnt, 4) = CStr(arrSht2(Cnt, 5)):: arrOut(Cnt, 5) = CStr(arrSht2(Cnt, 6))
Next Cnt
Rem 3 main loop ' == Start Main loop ================
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
' If IsError(MtchRes) Then ' case data is MISSING: NEW ( MISSING: ) ' This straight forward modification to the existing code will not work. This is because the code modifies the check array , arrSht2Chk() , when checking for the data from Original in NEW
' Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING:: " & arrSht1(Cnt, 2)
' Else:
'3a(ii) action whilst match is found --Inner Loop------
Do While Not IsError(MtchRes) ' The 3a Loop
Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
If DupyCnt > 1 Then
Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 1): arrOut(MtchRes, 2) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 2)
Else
Let arrOut(MtchRes, 1) = "": arrOut(MtchRes, 2) = "" ' remove the found data from array for output so that next line can look again for a possible duplicate
End If
Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
Loop ' ----------------------------------------
' End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Original with this line
Rem 3b Second Loop ' ##### Start Second loop #####
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
'Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
If IsError(MtchRes) Then ' case data is missing NEW ( MISSING: )
Let arrOut(Cnt, 1) = "MISSING: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING: " & arrSht1(Cnt, 2): arrOut(Cnt, 3) = "MISSING: " & arrSht1(Cnt, 4): arrOut(Cnt, 4) = "MISSING: " & arrSht1(Cnt, 5): arrOut(Cnt, 5) = "MISSING: " & arrSht1(Cnt, 6)
Else
End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ##### End Second Loop ################# effectively we go to next row of data in Original with this line


Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Result")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:F1").Value = "Original": Ws3.Range("G1:K1").Value = "Test Output": Ws3.Range("L1:Q1").Value = "NEW"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Ws3.Range("L2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Suggested test data to answer this post: http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10754#post10754

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

1Customer:Assembly #:Assembly Name:


2#Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


3
1
1
Nu Torque

13456
456
456


4
2
1
Blu Origin

Spaceship
457
457


5
3
2
Jet Blue21

ABC
458
458


6
4
3
EXCELL123

123
ABC
ABC


7
5
3
Toyota

Supra
460
460


8
6
2
Emirate

ABC12345
461
461


9
7
1
Angel

ABC12346
462
462
Worksheet: Original


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

1Customer:Assembly #:Assembly Name:


2#Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


3
1
1
Nu Torque

13456
456
456


4
2
1
Blu Origin

Spaceship
457
457


5
3
2
Jet Blue23

ABC
DEF
DEF


6
4
3
EXCELL123

123
ABC
ABC


7
5
3
Toyota

Supra
460
460


8
6
2
Emirate

ABC12345
461
461


9
3
2
Jet Blue21

ABC
458
458
Worksheet: NEW


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In the last code , ( Sub Testies ), the following output is obtained when using the suggested test data above ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10756#post10756 ) :


Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1OriginalOriginalOriginalOriginalOriginalOriginalT est OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW


2Assembly #:Assembly Name: Assembly #:Assembly Name:


3Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


4
1Nu Torque
13456
456
456
1Nu Torque
13456
456
456


5
1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


6
2Jet Blue21ABC
458
4582Jet Blue23ABCDEFDEF
2Jet Blue23ABCDEFDEF


7
3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


8
3ToyotaSupra
460
460
3ToyotaSupra
460
460


9
2EmirateABC12345
461
461
2EmirateABC12345
461
461


10
1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
2Jet Blue21ABC
458
458
Worksheet: Result


Using Excel 2007 32 bit
Row\Col
G
H
I
J
K

1Test OutputTest OutputTest OutputTest OutputTest Output


2


3


4


5


62Jet Blue23ABCDEFDEF


7


8


9


10MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
Worksheet: Result



Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1OriginalOriginalOriginalOriginalOriginalOriginalT est OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW


6
2Jet Blue21ABC
458
4582Jet Blue23ABCDEFDEF
2Jet Blue23ABCDEFDEF
Worksheet: Result

_._____________________________________-

We have currently output like this:

Test OutputTest OutputTest OutputTest OutputTest Output

2Jet Blue23ABCDEFDEF
But We want this to look more similar to screenshot output from post #15 ( http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10754#post10754 )


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code to answer this post: http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10754#post10754



Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Original"), Worksheets("NEW"))
' Call Testy(Worksheets("Original"), Worksheets("NEW"))
' Call Testies(Worksheets("Original"), Worksheets("NEW"))
Call Tests28July(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Tests28July(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("B1:G" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("B1:G" & Lr1 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String, arrSht2ChkKopie() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2) - 1) ' -1 as one column , D is not required
ReDim arrSht1Chk(1 To UBound(arrSht1(), 1))
ReDim arrSht2Chk(1 To UBound(arrSht2(), 1))
ReDim arrSht2ChkKopie(1 To UBound(arrSht2(), 1))
'2b make check arrays fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
' Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
' Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2) & "|" & arrSht1(Cnt, 4) & "|" & arrSht1(Cnt, 5) & "|" & arrSht1(Cnt, 6)
Next Cnt
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
' Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2) & "|" & arrSht2(Cnt, 4) & "|" & arrSht2(Cnt, 5) & "|" & arrSht2(Cnt, 6)
Next Cnt
Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned to eachother
'2c make contents of array for output initially all dat from NEW
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2)): arrOut(Cnt, 3) = CStr(arrSht2(Cnt, 4)):: arrOut(Cnt, 4) = CStr(arrSht2(Cnt, 5)):: arrOut(Cnt, 5) = CStr(arrSht2(Cnt, 6))
Next Cnt
Rem 3 main loop ' == Start Main loop ================
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
' If IsError(MtchRes) Then ' case data is MISSING: NEW ( MISSING: ) ' This straight forward modification to the existing code will not work. This is because the code modifies the check array , arrSht2Chk() , when checking for the data from Original in NEW
' Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING:: " & arrSht1(Cnt, 2)
' Else:
'3a(ii) action whilst match is found --Inner Loop------
Do While Not IsError(MtchRes) ' The 3a Loop
Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
If DupyCnt > 1 Then
Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 1): arrOut(MtchRes, 2) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 2)
Else
Let arrOut(MtchRes, 1) = "": arrOut(MtchRes, 2) = "": arrOut(MtchRes, 3) = "": arrOut(MtchRes, 4) = "": arrOut(MtchRes, 5) = "" ' remove the found data from array for output so that next line can look again for a possible duplicate
End If
Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
Loop ' ----------------------------------------
' End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Original with this line
Rem 3b Second Loop ' ##### Start Second loop #####
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
'Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
If IsError(MtchRes) Then ' case data is missing NEW ( MISSING: )
Let arrOut(Cnt, 1) = "MISSING: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING: " & arrSht1(Cnt, 2): arrOut(Cnt, 3) = "MISSING: " & arrSht1(Cnt, 4): arrOut(Cnt, 4) = "MISSING: " & arrSht1(Cnt, 5): arrOut(Cnt, 5) = "MISSING: " & arrSht1(Cnt, 6)
Else
End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ##### End Second Loop ################# effectively we go to next row of data in Original with this line
Rem 3c(i) Third Loop ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
For Cnt = 1 To UBound(arrOut(), 1) Step 1 ' Counting at each row of output arrray
If InStr(1, arrOut(Cnt, 1), "MISSING:", vbBinaryCompare) <> 1 Then
Dim Cntx As Long ' for loop across "columns"
'3c(ii) Loop across columns in output array
For Cntx = 1 To 2 ' .....we need to break up into two loops, as we have columns in Output array of 1 2 3 4 5 but in Input array for sheet 1 we have B C D E F G .. D is ignored,
If arrOut(Cnt, Cntx) <> "" And arrOut(Cnt, Cntx) <> CStr(arrSht1(Cnt, Cntx)) Then ' condition for changed data
Let arrOut(Cnt, Cntx) = CStr(arrSht1(Cnt, Cntx)) & " < > " & arrOut(Cnt, Cntx)
Else
End If
Next Cntx
For Cntx = 3 To UBound(arrOut(), 2) ' we need to do break up into two loops......
If arrOut(Cnt, Cntx) <> "" And arrOut(Cnt, Cntx) <> CStr(arrSht1(Cnt, Cntx + 1)) Then ' condition for changed data
Let arrOut(Cnt, Cntx) = CStr(arrSht1(Cnt, Cntx + 1)) & " < > " & arrOut(Cnt, Cntx)
Else
End If
Next Cntx
Else ' case we have a Missing row, so no action in Third Loop 3c
End If
Next Cnt ' @@@@@ End Third Loop ' @@@@@@@@@@@@@@@@@

Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Result")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:F1").Value = "Original": Ws3.Range("G1:K1").Value = "Test Output": Ws3.Range("L1:Q1").Value = "NEW"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Ws3.Range("L2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub

[DocAElstein]

Sample test results for code from last post ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10758#post10758 )

Using Excel 2007 32 bit

OriginalOriginalOriginalOriginalOriginalOriginalTe st OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW

Assembly #:Assembly Name: Assembly #:Assembly Name:

Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


1Nu Torque
13456
456
456
1Nu Torque
13456
456
456


1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


2Jet Blue21ABC
458
4582Jet Blue21 < > Jet Blue23ABC458 < > DEF458 < > DEF
2Jet Blue23ABCDEFDEF


3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


3ToyotaSupra
460
460
3ToyotaSupra
460
460


2EmirateABC12345
461
461
2EmirateABC12345
461
461


1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
2Jet Blue21ABC
458
458
Worksheet: Result


Using Excel 2007 32 bit

Test OutputTest OutputTest OutputTest OutputTest Output









2Jet Blue21 < > Jet Blue23ABC458 < > DEF458 < > DEF







MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
Worksheet: Result



https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Code for alternative(2) output
In support of this post:
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10764#post10764



Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Original"), Worksheets("NEW"))
' Call Testy(Worksheets("Original"), Worksheets("NEW"))
' Call Testies(Worksheets("Original"), Worksheets("NEW"))
' Call Tests28July(Worksheets("Original"), Worksheets("NEW"))
Call Out2Testies(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Out2Testies(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
If lr1_1 > Lr1_2 Then
Let Lr1 = lr1_1
Else
Let Lr1 = Lr1_2
End If
Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
Let arrSht1() = Ws1.Range("B1:G" & Lr1 & "").Value
Let arrSht2() = Ws2.Range("B1:G" & Lr1 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String, arrSht2ChkKopie() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
' ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2) - 1) ' -1 as one column , D is not required
ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To 1) ' arrOut() is now only one column, as I am using the concatenated string in the output
ReDim arrSht1Chk(1 To UBound(arrSht1(), 1))
ReDim arrSht2Chk(1 To UBound(arrSht2(), 1))
ReDim arrSht2ChkKopie(1 To UBound(arrSht2(), 1))
'2b make check arrays fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
For Cnt = 1 To UBound(arrSht1(), 1) Step 1
' Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
' Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & " " & arrSht1(Cnt, 2) & " " & arrSht1(Cnt, 4) & " " & arrSht1(Cnt, 5) & " " & arrSht1(Cnt, 6)
Next Cnt
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
' Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & " " & arrSht2(Cnt, 2) & " " & arrSht2(Cnt, 4) & " " & arrSht2(Cnt, 5) & " " & arrSht2(Cnt, 6)
Next Cnt
Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned to eachother
'2c make contents of array for output initially all dat from NEW
For Cnt = 1 To UBound(arrSht2(), 1) Step 1
Let arrOut(Cnt, 1) = arrSht2Chk(Cnt)
Next Cnt
Rem 3 main loop ' == Start Main loop ================
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
' If IsError(MtchRes) Then ' case data is MISSING: NEW ( MISSING: ) ' This straight forward modification to the existing code will not work. This is because the code modifies the check array , arrSht2Chk() , when checking for the data from Original in NEW
' Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING:: " & arrSht1(Cnt, 2)
' Else:
'3a(ii) action whilst match is found --Inner Loop------
Do While Not IsError(MtchRes) ' The 3a Loop
Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
If DupyCnt > 1 Then
Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrSht2ChkKopie(MtchRes)
Else
Let arrOut(MtchRes, 1) = ""
End If
Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
Loop ' ----------------------------------------
' End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Original with this line
Rem 3b Second Loop ' ##### Start Second loop #####
For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
'Dim MtchRes As Variant
Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
If IsError(MtchRes) Then ' case data is missing NEW ( MISSING: )
Let arrOut(Cnt, 1) = "MISSING: " & arrSht1Chk(Cnt)
Else
End If '
Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
Next Cnt ' ##### End Second Loop ################# effectively we go to next row of data in Original with this line
Rem 3c(i) Third Loop ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
For Cnt = 1 To UBound(arrOut(), 1) Step 1 ' Counting at each row of output arrray
If InStr(1, arrOut(Cnt, 1), "MISSING:", vbBinaryCompare) <> 1 Then
If arrOut(Cnt, 1) <> "" Then '
Let arrOut(Cnt, 1) = arrSht1Chk(Cnt) & " < > " & arrOut(Cnt, 1)
Else
End If
Else ' case we have a Missing row, so no action in Third Loop 3c
End If
Next Cnt ' @@@@@ End Third Loop ' @@@@@@@@@@@@@@@@@


Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Result")
Ws3.Cells.ClearContents
Let Ws3.Range("A1:F1").Value = "Original": Ws3.Range("G1").Value = "Test Output": Ws3.Range("H1:M1").Value = "NEW"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), 1).Value = arrOut()
Let Ws3.Range("H2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is " & AdedRows & vbCrLf & "Changed cells is " & DifCnt
End Sub

[DocAElstein]

test results from code above, ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10762#post10762 ) in support of this post:
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10764#post10764

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1OriginalOriginalOriginalOriginalOriginalOriginalT est OutputNEWNEWNEWNEWNEWNEW


2Assembly #:Assembly Name: Assembly #:Assembly Name:


3Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


4
1Nu Torque
13456
456
456
1Nu Torque
13456
456
456


5
1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


6
2Jet Blue21ABC
458
4582 Jet Blue21 ABC 458 458 < > 2 Jet Blue23 ABC DEF DEF
2Jet Blue23ABCDEFDEF


7
3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


8
3ToyotaSupra
460
460
3ToyotaSupra
460
460


9
2EmirateABC12345
461
461
2EmirateABC12345
461
461


10
1AngelABC12346
462
462MISSING: 1 Angel ABC12346 462 462
2Jet Blue21ABC
458
458
Worksheet: Result

Using Excel 2007 32 bit

OriginalOriginalOriginalOriginalOriginalOriginalTe st OutputNEWNEWNEWNEWNEWNEW

Assembly #:Assembly Name: Assembly #:Assembly Name:

Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


1Nu Torque
13456
456
456
1Nu Torque
13456
456
456


1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


2Jet Blue21ABC
458
4582 Jet Blue21 ABC 458 458 < > 2 Jet Blue23 ABC DEF DEF
2Jet Blue23ABCDEFDEF


3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


3ToyotaSupra
460
460
3ToyotaSupra
460
460


2EmirateABC12345
461
461
2EmirateABC12345
461
461


1AngelABC12346
462
462MISSING: 1 Angel ABC12346 462 462
2Jet Blue21ABC
458
458
Worksheet: Result


Using Excel 2007 32 bit
Row\Col
G

1Test Output


2


3


4


5


62 Jet Blue21 ABC 458 458 < > 2 Jet Blue23 ABC DEF DEF


7


8


9


10MISSING: 1 Angel ABC12346 462 462
Worksheet: Result

[DocAElstein]

Test data in support of this Post:
http://www.excelfox.com/forum/showthread.php/2278-Compare-each-complete-row-of-sheet2-with-sheet3-each-complete-row?p=10766#post10766



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

11 L 11 L 1,1 L 1


21 G 11 E 11 L 1,1 L 11 E 1


31 G 11 E 11 L 1,1 L 11 E 11 G 1


41 E 11 G 1


5
Worksheet: Sheet2


Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J

11 L 11 E 11 L 1,1 L 11 G 1


21 G 11 E 11 L 11 L 11 G 1


31 L 11 L 1,1 L 11 L 11 G 1


41 L 11 L 1,1 L 1


51 L 11 G 11 E 11 L 1


61 G 11 L 11 L 1,1 L 11 L 11 L 11 G 1


71 E 11 E 11 L 1,1 L 11 L 11 G 1


81 E 11 G 11 E 11 L 1,1 L 11 G 11 G 11 G 11 G 1


91 E 11 E 11 L 11 L 11 G 11 G 11 G 11 G 11 G 1


10
Worksheet: Sheet3


_._______________________

The results after running the code given on Post #3 of main Thread ( http://www.excelfox.com/forum/showthread.php/2278-Compare-each-complete-row-of-sheet2-with-sheet3-each-complete-row?p=10766#post10766 )
Using Excel 2007 32 bit
Row\Col
A
B
C
D

120abc


2abc20


3def


4ghi


5
Worksheet: Sheet4


https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

( this is original post 11279 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11279&viewfull=1#post11279
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11279&viewfull=1#post11279 )




Attaching a File to a Thread post at excelfox
1 To get Manage Attachments Window dialogue box
First you must get up the Manage Attachments Window dialogue box.

_(i) For a new Thread
Either
_1_(i) _a) Select Paper clip icon https://imgur.com/owxsBy5
http://i.imgur.com/owxsBy5.jpg
Or
_1_(i) _b) Scroll down and select manage attachments
a)PaperClipIcon or b)ManageAttachmants.JPG : http://i.imgur.com/3VAkJO9.jpg https://imgur.com/YFEUDUh
http://i.imgur.com/3VAkJO9.jpg
https://imgur.com/YFEUDUh

(ii) For a Reply or when Editing an existing post
_ Hit Reply button or Edit Post Button
Reply or Edit Post.JPG : https://imgur.com/Bm1Zy6T
_ Hit Go Advanced button
GoAdvancedReplyWindow.JPG , GoAdvanced1.JPG : https://imgur.com/QLhHBGl , https://imgur.com/WXoKcoF
_ Scroll down and select manage attachments
Scroll down to Hit manage Attachments.JPG : https://imgur.com/uNkr6Eq



Finally you should see the Manage Attachments Window dialogue box
Manage Attachments Window dialogue box.JPG : https://imgur.com/BFFUIuG
21033595

Using this dialogue box window you can manage your attachments
2 To add a File to the current post:
Steps like the following are needed to attach a file to the current post. It may look a little bit different on your computer
_ Add Files.JPG : https://imgur.com/hIdo0Av
_ SelectFiles.JPG : https://imgur.com/9XZJuig
_ UploadFiles5.JPG : https://imgur.com/f0PXtVA
_ Done6.JPG : https://imgur.com/a6oFeIQ
That's it!...:)
The file should now have been attached.


_._______

Practice before posting in a main Thread:
You can practice uploading a file by starting a new test thread here:
http://www.excelfox.com/forum/forumdisplay.php/17-Test-Area
Give the Thread a title such as …”Just testing. No Reply needed”
Test Area new Thread 1 .JPG , Test Area new Thread just testing .JPG https://imgur.com/S3uneWf , https://imgur.com/gUFHcBp

You can then practice uploading attachments or you can also practice any other posting and editing features, such as code tags ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10690#post10690 )

_._____________________________



Alternative to attaching a file: post a link to your file held at a file share site:
See here for example:
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page8#post10725
Or if you are familiar with file sharing sites go direct here
https://account.box.com/signup/n/personal#58luf

[DocAElstein]

( this is copied post 15589 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11279&viewfull=1#post15589
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11279&viewfull=1#post15589
Images may work better in this Post if you are using an older Operating System
)


Attaching a File to a Thread post at excelfox
1 To get Manage Attachments Window dialogue box
First you must get up the Manage Attachments Window dialogue box.

_(i) For a new Thread
Either
_1_(i) _a) Select Paper clip icon https://imgur.com/owxsBy5
http://i.imgur.com/owxsBy5.jpg
Or
_1_(i) _b) Scroll down and select manage attachments
a)PaperClipIcon or b)ManageAttachmants.JPG : http://i.imgur.com/3VAkJO9.jpg
http://i.imgur.com/YFEUDUh.jpg
a)PaperClipIcon: http://i.imgur.com/3VAkJO9.jpg
b)ManageAttachmants.JPG: http://i.imgur.com/YFEUDUh.jpg

(ii) For a Reply or when Editing an existing post
_ Hit Reply button or Edit Post Button
Reply or Edit Post.JPG : http://i.imgur.com/Bm1Zy6T.jpg
_ Hit Go Advanced button
GoAdvancedReplyWindow.JPG , GoAdvanced1.JPG : http://i.imgur.com/QLhHBGl.jpg , http://i.imgur.com/WXoKcoF.jpg
_ Scroll down and select manage attachments
Scroll down to Hit manage Attachments.JPG : http://i.imgur.com/uNkr6Eq.jpg



Finally you should see the Manage Attachments Window dialogue box
Manage Attachments Window dialogue box.JPG : http://i.imgur.com/BFFUIuG.jpg
21033594

Using this dialogue box window you can manage your attachments
2 To add a File to the current post:
Steps like the following are needed to attach a file to the current post. It may look a little bit different on your computer
_ Add Files.JPG : http://i.imgur.com/hIdo0Av.jpg
_ SelectFiles.JPG : http://i.imgur.com/9XZJuig.jpg
_ UploadFiles5.JPG : http://i.imgur.com/f0PXtVA.jpg
_ Done6.JPG : http://i.imgur.com/a6oFeIQ.jpg
That's it!...:)
The file should now have been attached.


_._______

Practice before posting in a main Thread:
You can practice uploading a file by starting a new test thread here:
http://www.excelfox.com/forum/forumdisplay.php/17-Test-Area
Give the Thread a title such as …”Just testing. No Reply needed”
Test Area new Thread 1 .JPG , Test Area new Thread just testing .JPG http://i.imgur.com/S3uneWf.jpg , http://i.imgur.com/gUFHcBp.jpg

You can then practice uploading attachments or you can also practice any other posting and editing features, such as code tags ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10690#post10690 )

_._____________________________



Alternative to attaching a file: post a link to your file held at a file share site:
See here for example:
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page8#post10725
Or if you are familiar with file sharing sites go direct here
https://account.box.com/signup/n/personal#58luf



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10771#post10771

Using Excel 2007 32 bit
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1OriginalOriginalOriginalOriginalOriginalOriginalT est OutputTest OutputTest OutputTest OutputTest OutputNEWNEWNEWNEWNEWNEW


2Assembly #:Assembly Name: Assembly #:Assembly Name:


3Qty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PNQty PerRef/DesignatorDescriptionCustomer PNInternal PNManufacture PN


4
1Nu TorqueABC
456
456ABC < > 13456
1Nu Torque
13456
456
456


5
1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


6
2Jet Blue21ABC
458
458
2New: Jet Blue23ABCNew: DEFNew: DEF
2Jet Blue23ABCDEFDEF


7
3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


8
3ToyotaSupra
460
460
3ToyotaSupra
460
460


9
2EmirateABC12345
461
461
2EmirateABC12345
461
461


10
1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
2Jet Blue21ABC
458
458
Worksheet: Result Wanted




Using Excel 2007 32 bit


1Nu TorqueABC
456
456ABC < > 13456
1Nu Torque
13456
456
456


1Blu OriginSpaceship
457
457
1Blu OriginSpaceship
457
457


2Jet Blue21ABC
458
458
2New: Jet Blue23ABCNew: DEFNew: DEF
2Jet Blue23ABCDEFDEF


3EXCELL123
123ABCABC
3EXCELL123
123ABCABC


3ToyotaSupra
460
460
3ToyotaSupra
460
460


2EmirateABC12345
461
461
2EmirateABC12345
461
461


1AngelABC12346
462
462MISSING: 1MISSING: AngelMISSING: ABC12346MISSING: 462MISSING: 462
2Jet Blue21ABC
458
458
Worksheet: Result Wanted

[DocAElstein]

Code for Yasser, here: http://www.eileenslounge.com/viewtopic.php?f=30&t=31150&p=241152#p241148





Option Explicit
Sub SUMfromD14inClsdWkBksInFolder() ' Loop through closed workbooks without opening them ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31150&p=241152#p241152
' Use Dir function with wildcards in full path and name search string to find file names you want
Dim FileName As String:
Let FileName = Dir("C:\Users\Elston\Desktop\YassersFolder\*record*", vbNormal) ' The Dir function uased the first time here, it will find the first file with "record" in its file name in the folder , "YassersFolder". If it does not find one, it will return "". If it finds one, then variable FileName will be given its name, ( just the name, not the entire file path and name)
'Do do Looping while you find the file names you want =========
Do While Not FileName = "" ' Dir Function will return "" if it finds no new File names of the ones looking for. If it does find a File name, then use that filename in the closed workbook reference which you put in a spare cell, for example, A1
Let ThisWorkbook.Worksheets.Item(1).Range("A1").Value = "=" & "'" & "C:\Users\Elston\Desktop\YassersFolder\" & "[" & FileName & "]Tabelle1'!$D$14"
Dim SomeTotal As Double ' A variable to hold the Sum total so far
Let SomeTotal = SomeTotal + ThisWorkbook.Worksheets.Item(1).Range("A1").Value
Let FileName = Dir ' an unqualified Dir will look again using the last search criteria, so the first time this line is used, Dir Function will try to find a second file with the string part "record" in its file name
Loop ' do while you find the file names you want ==========
Let ThisWorkbook.Worksheets.Item(1).Range("A10").Value = SomeTotal
End Sub

[DocAElstein]

Codes to support this
https://www.thespreadsheetguru.com/blog/the-vba-guide-to-named-ranges#comment-4189507335

....

The main demo code is Sub NamedRangeScopes() , but that Calls the others, so copy them all to the same code module , and then run the main demo code, Sub NamedRangeScopes()




Sub NamedRangeScopes()
10 Call FukOffNames
20 Call getWbNames
30 Rem 1 Add 3 named ranges, 1(i) '_-in the Workbooks name object collection, and 1(ii) in the first worksheet name object collection and 1(iii) '_-in the second worksheet name object collection
40 '1(i) Add a Workbook names object in the Workbook name object collection of this workbook
50 ThisWorkbook.Names.Add Name:="Name1", RefersTo:=ThisWorkbook.Worksheets.Item(1).Range("A1") '_-in the Workbooks name object collection
60 'The form above is like ThisWorkbook.Names.Add Name:="Name1", RefersTo:=Worksheets(Sheet1).Range("A1")
70 '1(ii) Add a name object in the first worksheet's name object collection
80 ThisWorkbook.Worksheets.Item(1).Names.Add Name:="Name1", RefersTo:=ThisWorkbook.Worksheets.Item(1).Range("A1") '_-in the first worksheet name object collection
90 'The form above is like Worksheets("Sheet1).Names.Add Name:="Name1" , RefersTo:=Sheet1.Range("A1")
100 '1(iii) Add a name object in the second worksheet's name object collection
110 ThisWorkbook.Worksheets.Item(2).Names.Add Name:="Name2", RefersTo:=ThisWorkbook.Worksheets.Item(2).Range("A1") '_-in the second worksheet name object collection
120 'The form above is like Worksheets("Sheet2).Names.Add Name:="Name2" , RefersTo:=Sheet2.Range("A1")
130 Rem 2 Change the string name of a named range
140 Call GetChaNameObjects(140) ' Check out Info for all Name objects
150 '2a) Use Workbook names objects to Change the worksheet names object name that has the same name as the workbook names object name, change it twice, first using the workbook names object collection and then the worksheet names object collection
160 Let ThisWorkbook.Names(ThisWorkbook.Worksheets.Item(1) .Name & "!" & "Name1").Name = "Name1_1"
170 ' The form above is like ThisWorkbook.Names("Sheet1!Name").Name = "Name1_1"
180 Call GetChaNameObjects(180)
190 Let ThisWorkbook.Worksheets.Item(1).Names(ThisWorkbook .Worksheets.Item(1).Name & "!" & "Name1_1").Name = "Name1_2"
200 Call GetChaNameObjects(200)
210 Let ThisWorkbook.Worksheets.Item(1).Names("Name1_2").Name = "Name1_3"
220 Call GetChaNameObjects(220)
230 '2b) use a Worksheet's (in this example the second worksheet's) name objects to Change the second worksheet's names object, ( we gave it "Name2", but Excel adds a bit so it looks like Sheet2!Name2" which you can get from a VBA code line like ThisWorkbook.Worksheets.Item(2).Name & "!" & "Name2" I do t
his just in case your second worksheet has a tab name other than Sheet2
240 Let ThisWorkbook.Worksheets.Item(2).Names("Name2").Name = "Name2_2"
250 ' Note: you could have equally done this: Let ThisWorkbook.Worksheets.Item(2).Names(ThisWorkbook .Worksheets.Item(2).Name & "!" & "Name2").Name = "Name2_2" , which is like Let ThisWorkbook.Worksheets.Item(2).Names("Sheet2!Name2").Name = "Name2_2"
260 Call GetChaNameObjects(260)
270 Rem 3 Change the string name of a named range, for example the one in the second worksheet names collection whichg we just renamed to "Name2_2" ,(which Excel holds as like "Sheet2!Name2_2")
280 '3a) Use Workbook names objects
290 Let ThisWorkbook.Names(ThisWorkbook.Worksheets.Item(2) .Name & "!" & "Name2_2").RefersTo = ThisWorkbook.Worksheets.Item(2).Range("Z123")
300 Call GetChaNameObjects(300)
310 '3b) Use the second worksheets's names objects
320 Let ThisWorkbook.Worksheets.Item(2).Names("Name2_2").RefersTo = ThisWorkbook.Worksheets.Item(2).Range("X23")
330 Call GetChaNameObjects(330)
End Sub


Sub FukOffNames()
Dim Nme As Name
For Each Nme In ThisWorkbook.Names
Nme.Delete
Next Nme
End Sub


Sub GetChaNameObjects(ByVal CodLn As Long)
Dim Nme As Name, strOut As String
' Name objects belonging in Workbook Names Colection (Workbooks scope)
For Each Nme In ThisWorkbook.Names
If InStr(1, Nme.Name, "!", vbBinaryCompare) > 0 Then ' we will see that a name for a worksheet scope, has an extra bit added onto the name we gave it which includes a "!"
Let strOut = strOut & "Name object Name is """ & Nme.Name & """ (you gave """ & Mid(Nme.Name, 1 + InStr(1, Nme.Name, "!", vbBinaryCompare)) & """)" & vbCrLf & "It has worksheet scope and" & vbCrLf & "it refers to range """ & Nme.RefersTo & """" & vbCrLf & vbCrLf & vbCrLf
Else ' we will see that a name for a workbook scope, remains just as we gave it
Let strOut = strOut & "Name object Name is """ & Nme.Name & """ (the same as you gave)" & vbCrLf & "It has workbook scope and" & vbCrLf & "it refers to range """ & Nme.RefersTo & """" & vbCrLf & vbCrLf & vbCrLf
End If
Next Nme
MsgBox prompt:="Workbook names situation at Code Line " & CodLn & vbCrLf & vbCrLf & strOut, Title:="Name objects in Workbook """ & ThisWorkbook.Name & """ Names Colection are:-": Debug.Print "Name objects in Workbook """ & ThisWorkbook.Name & """ Names Colection are:-" & vbCr & strOut
' Name objects belonging in Workbooks Names Colection (Worksheets scope)
Dim Ws As Worksheet: Let strOut = ""
For Each Ws In ThisWorkbook.Worksheets
For Each Nme In Ws.Names
Let strOut = strOut & "Name object name is """ & Nme.Name & """ (you gave """ & Mid(Nme.Name, 1 + InStr(1, Nme.Name, "!", vbBinaryCompare)) & """)" & vbCrLf & "It has worksheets scope and" & vbCrLf & "it belongs to the Names collection of worksheet """ & Ws.Name & """" & vbCrLf & "and it refers to range """ & Nme.RefersTo & """" & vbCrLf & vbCrLf
Next Nme
Next Ws
MsgBox prompt:="Worksheets names situation at Code Line " & CodLn & vbCrLf & vbCrLf & strOut, Title:="Name objects in all the worksheets Names Colections are:-": Debug.Print "Name objects in all the worksheets Names Colections are:-" & strOut
End Sub


Sub getWbNames()
Dim Nme As Name, Cnt As Long
For Each Nme In ThisWorkbook.Names
Let Cnt = Cnt + 1
Dim strNames As String: Let strNames = strNames & Cnt & " "
If TypeOf Nme.Parent Is Worksheet Then ' https://stackoverflow.com/questions/8656793/progammatically-determine-if-a-named-range-is-scoped-to-a-workbook
Let strNames = strNames & """" & Nme.Name & """ refers to the range ref """ & Nme & """ and and can be referenced only from worksheet with tab Name """ & Nme.Parent.Name & """ ( Worksheet Scope ). ( That worksheet is in the workbook """ & Nme.Parent.Parent.Name & """ )" & vbCrLf & vbCrLf
Else
Let strNames = strNames & """" & Nme.Name & """ refers to the range ref """ & Nme & """ and can be referenced from any sheet in the Workbook """ & Nme.Parent.Name & """ ( Workbook Scope )" & vbCrLf & vbCrLf
End If
Next Nme
If strNames = "" Then
MsgBox prompt:="I don't think you have any Names at the moment luvy"
Else
MsgBox prompt:=strNames, Title:="Spreadsheet Named range objects in " & ThisWorkbook.Name & " are:-": Debug.Print strNames
End If
End Sub



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

First main Demo code in support of this Thread:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range
Posts from approximately here:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range?p=10814#post10814:



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Second main Demo Code in support of this Thread:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range
For Posts from:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range?p=10819#post10819




Sub FoxyMultiCellNamedRanges()
10 Rem -2 Range Info etc.
20 Dim WbMain As Workbook, dataWb1xls As Workbook, dataWb2xlsx As Workbook
30 Set WbMain = Workbooks("MasturFile.xlsm") 'Set WbMain = ThisWorkbook
40 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
50 Set dataWb1xls = Workbooks("Data1.xls")
60 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
70 Set dataWb2xlsx = Workbooks("Data2.xlsx")
80 '
90 Dim LisWkBkPath As String: Let LisWkBkPath = "=" & "'" & ThisWorkbook.Path & "\"
100 '-2b) Some variables to hold a full reference string which we will use in places where we might need any of these variations for a cell reference Sheet7!B5 [myWorkbook.xlsm] Sheet4!B5 'G:\Desktop\MyFolder\[DataFile.xlsx]Tabelle1'!B5 The last one is the form we hold in the variables. Excel and Excel VBA , usually has no issues if you use the full reference in situations where one of the shorter versions may have been sufficient. But on the other hand, you may get unexpected problems if you used a shorter version , and Excel then guesses wrongly for the remaining part, which I believe it always adds internally, ( possibly at some compiling stage ) , before it uses it.
110 Dim MBkTab1B5 As String ' To hold full string reference to B5 in Master Workbook
120 Let MBkTab1B5 = "=" & "'" & ThisWorkbook.Path & "\" & "[" & "MasturFile.xlsm" & "]" & "Tabelle1" & "'" & "!" & "B5"
130 Dim Dat1Tab1B5 As String ' B5 in data1 workbook
140 Let Dat1Tab1B5 = "=" & "'" & ThisWorkbook.Path & "\" & "[" & "Data1.xls" & "]" & "Tabelle1" & "'" & "!" & "B5"
150 '
160 Rem -1 Error handler
170 On Error GoTo ErrorHandlerCodeSection:
180 GoTo PastErrorHandler
190 ErrorHandlerCodeSection:
200 MsgBox prompt:="Code errored at line " & Erl & " , error was:" & vbCrLf & vbCrLf & Err.Number & " " & Err.Description
210 Debug.Print Err.Number & " " & Err.Description
220 Resume Next
230 PastErrorHandler:
240 Rem 0 Clean up
250 '0a) remove any name objects made in last routine in the main file or the two data files
260 Dim WkBk As Workbook
270 For Each WkBk In Workbooks
280 Call FukYaWkBkNames(WkBk)
290 'Call GeTchaNms(280, WkBk)
300 Next WkBk
310 Workbooks("Data1.xls").Close savechanges:=True
320 Workbooks("Data2.xlsx").Close savechanges:=True
330 '0b) clear the entire data ranges in the first worksheet in the main workbook, both headers and data
340 ThisWorkbook.Worksheets.Item(1).Range("B5:C12").ClearContents
350 Rem _1) Data1 "Food" header
360 '1a) Data1 cell Workbook Scoped to its workbook : Info needed for a range in that data file is held in the workbooks name objects collection object of that workbook
370 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
380 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
390 dataWb1xls.Names.Add Name:="Dta1Foodheader", RefersTo:=Application.Range(Dat1Tab1B5) ' A personal preference of mine is , once again, to use a full reference. This time it is in the Refers To range. This Refers To:= argument would never need the full file path reference, as the range referenced must be to a range in an open book. Never the less, as usual, VBA accepts the full reference
400 dataWb1xls.Close savechanges:=True ' I don't need the workbook open for the next line to work, but I made Added a named range object so I must save the changes for the next line to work as that named range is referenced
410 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "Data1.xls'!Dta1Foodheader" ' "Going" to Workbook Data1.xls
420 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "[Data1.xls]Tabelle4'!Dta1Foodheader" ' "Going" to any worksheet in Data1.xls
430 Rem 2 Experiments with named ranges in the LHS , like in Range("rngNamed") =
440 '2b) Workbooks Scope to main workbook: Info for named range is in Name Objects collection of Main workbook
450 WbMain.Names.Add Name:="MainFoodheader", RefersTo:=Application.Range(MBkTab1B5)
460 Let Application.Range(LisWkBkPath & WbMain.Name & "'!MainFoodheader").Value = LisWkBkPath & "Data1.xls'!Dta1Foodheader" ' LHS is going to workbook Data2.xlsx RHS is "Going" to Workbook Data1.xls
470 Rem 3 Bring in Header "Suppliment" from data 2 workbook directly without named ranges
480 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
490 Set dataWb2xlsx = Workbooks("Data2.xlsx") ' Needed for next line
500 Let Application.Range("=" & "'" & WbMain.Path & "\" & "[" & WbMain.Name & "]" & WbMain.Worksheets.Item(1).Name & "'" & "!" & "B10").Value = "=" & "'" & dataWb2xlsx.Path & "\" & "[" & dataWb2xlsx.Name & "]" & dataWb2xlsx.Worksheets.Item(1).Name & "'" & "!" & "B10"
510 '3b) "Fixed vector" B11 into main workbook at B11
520 Let Application.Range("=" & "'" & WbMain.Path & "\" & "[" & WbMain.Name & "]" & WbMain.Worksheets.Item(1).Name & "'" & "!" & "B11").Value = "=" & "'" & dataWb2xlsx.Path & "\" & "[" & dataWb2xlsx.Name & "]" & dataWb2xlsx.Worksheets.Item(1).Name & "'" & "!" & "B11"
530 '3c) "Fixed vector" B11 into main workbook into B11 C11 B12 and C12
540 Let Application.Range("=" & "'" & WbMain.Path & "\" & "[" & WbMain.Name & "]" & WbMain.Worksheets.Item(1).Name & "'" & "!" & "B11:C12").Value = "=" & "'" & dataWb2xlsx.Path & "\" & "[" & dataWb2xlsx.Name & "]" & dataWb2xlsx.Worksheets.Item(1).Name & "'" & "!" & "B11"
550 dataWb2xlsx.Close savechanges:=False
560 '
570 Application.Range("=" & "'" & WbMain.Path & "\" & "[" & WbMain.Name & "]" & WbMain.Worksheets.Item(1).Name & "'" & "!" & "B11:C12").ClearContents ' remove the data from the main file from data file 2 so as to do the same again using named ranges in the next code section, Rem 4
580 Rem 4 named ranges for data ranges in data workbooks and main file
590 '4a) Workbook to store name range object
600 Dim WbNmeObjs As Workbook
610 Workbooks.Open Filename:=ThisWorkbook.Path & "\StoredNamedRangeNameObjects.xls"
620 Set WbNmeObjs = Workbooks("StoredNamedRangeNameObjects.xls")
630 Call FukYaWkBkNames(WbNmeObjs)
640 Call GeTchaNms(640, WbNmeObjs)
650 '4b) named ranges for data in data range from data 1 workbook, "Data1.xls
660 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
670 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
680 WbNmeObjs.Worksheets("DataFileNameObjects").Names.Add Name:="NmsObjDta1Data", RefersTo:=Application.Range("='" & ThisWorkbook.Path & "\[Data1.xls]Tabelle1'!B6:C7")
690 Call GeTchaNms(690, WbNmeObjs)
700 '4c) named ranges for data in data range from data 2 workbook, "Data2.xlsx
710 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
720 Set dataWb2xlsx = Workbooks("Data2.xlsx") ' We need this open for the referred to range in the RefersTo:= range reference below
730 WbNmeObjs.Worksheets("DataFileNameObjects").Names.Add Name:="NmsObjDta2Data", RefersTo:=Application.Range("='" & ThisWorkbook.Path & "\[Data2.xlsx]Tabelle1'!B11:C12")
740 Call GeTchaNms(740, WbNmeObjs)
750 '4d) named ranges for data import ranges in main workbook, ( This workbook )
760 '4d(i) data from Data 1 file import range in main book
770 WbNmeObjs.Worksheets("MainFileNameObjects").Names.Add Name:="NmsObjDta1Import", RefersTo:=Application.Range("='" & ThisWorkbook.Path & "\[MasturFile.xlsm]Tabelle1'!B6:C7")
780 '4d(ii) data from Data 2 file import range in main book
790 WbNmeObjs.Worksheets("MainFileNameObjects").Names.Add Name:="NmsObjDta2Import", RefersTo:=Application.Range("='" & ThisWorkbook.Path & "\[MasturFile.xlsm]Tabelle1'!B11:C12")
800 Call GeTchaNms(800, WbNmeObjs)
810 ' Close data books - I don't need them open to get at their named range data or their named range data
820 dataWb1xls.Close savechanges:=False ' I needed the workbook open for the referes to range reference and the GeTchaNms( ) to work, but i added no names to it, so I did not intentiionally make any changes, so I will close with changes false in case I acidentally changed anything
830 dataWb2xlsx.Close savechanges:=False ' I needed the workbook open for the referes to range reference and the GeTchaNms( ) to work, but i added no names to it, so I did not intentiionally make any changes, so I will close with changes false in case I acidentally changed anything
840 Rem 5 Using the Added data named ranges to bring in data from the data files into the main workbook
850 '5a) Food data data range ( B6:C7 in main File and B6:C7 in data 1 file )
860 Let Application.Range("='" & ThisWorkbook.Path & "\[StoredNamedRangeNameObjects.xls]MainFileNameObjects'!NmsObjDta1Import").FormulaArray = "='" & ThisWorkbook.Path & "\[StoredNamedRangeNameObjects.xls]DataFileNameObjects'!NmsObjDta1Data"
870 '5a)(ii) As file "StoredNamedRangeNameObjects.xls" is open we can also use
880 Let Application.Range("='[StoredNamedRangeNameObjects.xls]MainFileNameObjects'!NmsObjDta1Import").FormulaArray = "='[StoredNamedRangeNameObjects.xls]DataFileNameObjects'!NmsObjDta1Data"
890 '5b) Food data data range ( B11:C12 in main File and B11:C12 in data 2 file )
900 Let Application.Range("='" & ThisWorkbook.Path & "\[StoredNamedRangeNameObjects.xls]MainFileNameObjects'!NmsObjDta2Import").FormulaArray = "='" & ThisWorkbook.Path & "\[StoredNamedRangeNameObjects.xls]DataFileNameObjects'!NmsObjDta2Data"
910 '5b)(ii) As file "StoredNamedRangeNameObjects.xls" is open we can also use
920 Let Application.Range("='[StoredNamedRangeNameObjects.xls]MainFileNameObjects'!NmsObjDta2Import").FormulaArray = "='[StoredNamedRangeNameObjects.xls]DataFileNameObjects'!NmsObjDta2Data"
930 '5c)
940 WbNmeObjs.Close savechanges:=True ' Save the named range info on closing
950 '5d) Optional Change all formulas to their values
960 Let WbMain.Worksheets.Item(1).UsedRange.Value = WbMain.Worksheets.Item(1).UsedRange.Value
970 Rem 6 Final check of all named ranges
980 '6a) Open all workbooks so as to access Named range objects in them
990 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
1000 Set dataWb1xls = Workbooks("Data1.xls")
1010 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
1020 Set dataWb2xlsx = Workbooks("Data2.xlsx")
1030 Workbooks.Open Filename:=ThisWorkbook.Path & "\StoredNamedRangeNameObjects.xls"
1040 Set WbNmeObjs = Workbooks("StoredNamedRangeNameObjects.xls")
1050 '6b) Loop through all open workbooks and check named range object info
1060 Dim Wbtemp As Workbook
1070 For Each Wbtemp In Workbooks ' Going through each workbook in the Workbooks collection object of open workbooks
1080 Call GeTchaNms(1080, Wbtemp)
'1085 If Wbtemp.Name <> ThisWorkbook.Name Then Wbtemp.Close savechanges:=False ' Close all but this workbook - can't do this here - I might need them in the next use of GeTchaNms
1090 Next Wbtemp
'close workbooks
1100 For Each Wbtemp In Workbooks ' Going through each workbook in the Workbooks collection object of open workbooks
1110 If Wbtemp.Name <> ThisWorkbook.Name Then Wbtemp.Close savechanges:=False ' Close all but this workbook
1120 Next Wbtemp

End Sub

[DocAElstein]

Support Called routines for Thread:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range




Sub FukYaWkBkNames(ByVal WnkBuk As Workbook)
Dim Nme As Name
For Each Nme In WnkBuk.Names
Nme.Delete
Next Nme
End Sub
Sub GeTchaNms(ByVal CodLn As Long, ByVal WnkBuk As Workbook) ' To get info aboout all Name objects in a Workbook,m WnkBuk
Dim Cnt As Long, Nme As Name, strOut As String
' Name objects in Workbook Names Colection object (Workbooks scope and Worksheets scope)
For Each Nme In WnkBuk.Names ' For convenience it goes through the Workbook named objects collection object for a workbook, as this has "its own" named range objects, that is to say the Workbooks scoped named range objects, and also the named range objects for all the worksheets. So I do not need to go through the named range objects collection object of every worksheet in that workbook separately for every worksheet.
Let Cnt = Cnt + 1 ' A simple count number of each workbooks collection names objects in order it finds in looping them
' We look now for a "!" in the string name, ... Excel adds a bit onto the name we give to a name Added to a Worksheet’s named objects collection ( Scoped to a Worksheet’s named objects collection = worksheet “scoping” We scoped to the Names object of a particular Worksheet = We Added the named range Name object to the names objects collection object of that particular Worksheet( and also indirectly the names objects collection object of the workbook in which that worksheet is) = We scoped that named range to that Workbook = That named range has Workbook Scope ). That added bit is something like “Sheet1!” . In other words, if you had given Name:=”MyName” in a code line for a worksheets scope Named range object Addition, like, …_ Worksheets("Sheet2").Names.Add Name:="FoodHeader", RefersTo:=____ _.. Then excel seems to hold and use a name like “Sheet2!FoodHeader"
If InStr(1, Nme.Name, "!", vbBinaryCompare) > 0 Then ' A name for a worksheet scope, has an extra bit added onto the name we gave it which includes a "!"
Let strOut = strOut & Cnt & " Name object Name is """ & Nme.Name & """" & vbCrLf & "(you gave """ & Mid(Nme.Name, 1 + InStr(1, Nme.Name, "!", vbBinaryCompare)) & """)" & vbCrLf & "It has worksheet scope and" & vbCrLf & "it refers to range """ & Nme.RefersTo & """" & vbCrLf & "and if in a spreadsheet formula you only want to use" & vbCrLf & """" & Mid(Nme.Name, 1 + InStr(1, Nme.Name, "!", vbBinaryCompare)) & """ without any preceding info about" & vbCrLf & "where that named range is," & vbCrLf & "then you must be in spreadsheet with tab name """ & Nme.Parent.Name & """" & vbCrLf & "If you want to be sure to access this named range from anywhere," & vbCrLf & "you should use """ & "=" & "'" & WnkBuk.Path & "\" & "[" & WnkBuk.Name & "]" & Nme.Parent.Name & "'" & "!" & Mid(Nme.Name, 1 + InStr(1, Nme.Name, "!", vbBinaryCompare)) & """"
If Nme.Parent.Name <> Application.Range(Nme.RefersTo).Parent.Name Then Let strOut = strOut & vbCrLf & "Note: The refered to range is in worksheet """ & Application.Range(Nme.RefersTo).Parent.Name & """"
If Nme.Parent.Parent.Name <> Application.Range(Nme.RefersTo).Parent.Parent.Name Then Let strOut = strOut & vbCrLf & "Note also: The refered to range is in File """ & Application.Range(Nme.RefersTo).Parent.Parent.Name & """"
Else ' Assume we have a workbook scoped name... we will see that a name for a workbook scope, remains just as we gave it
Let strOut = strOut & Cnt & " Name object Name is """ & Nme.Name & """ (the same as you gave)" & vbCrLf & "It has workbook scope and" & vbCrLf & "it refers to range """ & Nme.RefersTo & """" & vbCrLf & "and if in a spreadsheet formula you only want to use" & vbCrLf & """" & Nme.Name & """" & vbCrLf & "with no preceding info " & vbCrLf & "about where that named range is," & vbCrLf & "then you must be in any spreadsheet in workbook """ & Nme.Parent.Name & """" & vbCrLf & "If you want to be sure to access this named range from anywhere," & vbCrLf & "you should use """ & "=" & "'" & WnkBuk.Path & "\" & WnkBuk.Name & "'" & "!" & Nme.Name & """" & vbCrLf & "or alternatively use a similar string like this with any of the worksheets in it:" & vbCrLf & """" & "=" & "'" & WnkBuk.Path & "\" & "[" & WnkBuk.Name & "]" & WnkBuk.Worksheets.Item(1).Name & "'" & "!" & Nme.Name & """"
If WnkBuk.Name <> Nme.Parent.Name Then Let strOut = strOut & vbCrLf & "Note the refered to range is in" & vbCrLf & """" & Application.Range(Nme.RefersTo).Parent.Parent.Name & """ worksheets """ & Application.Range(Nme.RefersTo).Parent.Name & """ !!"
End If
Let strOut = strOut & vbCrLf & vbCrLf & vbCrLf ' To clearly seperate each name object
Next Nme
If strOut = "" Then
MsgBox prompt:="The workbooks names object collection object is empty," & vbCrLf & "and so there are no named range objects in" & vbCrLf & "workbook """ & WnkBuk.Name & """", Title:="At " & CodLn & " , for File """ & WnkBuk.Name & """": Debug.Print "'_= ========" & vbCrLf & "You have no named range Name objects in workbook " & WnkBuk.Name & vbCrLf & vbCrLf
Else
MsgBox prompt:=strOut, Title:="At " & CodLn & " , """ & WnkBuk.Name & """ Names Collection has:-": Debug.Print "'_= ========" & vbCrLf & "You have " & Cnt & " named range Name objects in workbook " & WnkBuk.Name & vbCrLf & strOut
End If
End Sub



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In support of this post:
http://www.excelfox.com/forum/showthread.php/2289-Named-Ranges-and-Named-Ranges-scope-Referencing-a-named-range?p=10814#post10814


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

1


2


3


4NutritionEnergy


5Food


6Orange
50


7Apfel
60


8


9


10Suppliment


11BCAA
398


12EAA
400


13


14


15
Worksheet: Tabelle1



https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

I am trying to do 2 things: Use 2 named ranges.. One works. The other doesn’t.
I have made a demo to help explain my problem
I have 3 Files: I have a Main Excel workbook file, usually open, and two other files, usually closed
_Main File is:- “Main.xls” https://app.box.com/s/u8yy4rcqg0eglvy362v13hyro8cgd9n7 – - This is usually open. It has all my codes in it
_A DataFile is:- “ClsdData.xls.” https://app.box.com/s/65w1hnih1vvay70vtdzk3da50we3gxvh – This is usually closed. It has 2 data ranges and one named range name object in it
ClsdDataDataRanges.JPG : https://imgur.com/vs0vX0G
_____ Workbook: ClsdData.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1dataA1dataB1


2
Worksheet: DataSht_1

_A third file is:- “NameObjectFile.xls” https://app.box.com/s/wsxycb3t2y1hmv0wr12cqav0qlcytzjn – This is usually closed, ( preferably ). It only has a named range name object in it

So the goal is to have a main file, “Main.xls” open whilst the files “ClsdData.xls.” and “NameObjectFile.xls” are closed, and from a code in the main file, “Main.xls” , put formulas of this sort of form in the first two cells of the main workbook.
NamedRangeReferrenceFormulasPutInMainFile.JPG : https://imgur.com/1wDM3ug
_____ Workbook: Main.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1= ' C: \ FolderPath \ [ClsdData.xls] DataSht_1 ' ! NameForDataSht_1A1 = ' C: \ FolderPath \ [NameObjectFile.xls] NameObjectsSht_1 ' ! NameForDataSht_1B1
Worksheet: Tabelle1
Those formulas “go” to the name objects of the named ranges with string names:
“ NameForDataSht_1A1” referring to the range of data file first cell ,
and
“NameForDataSht_1B1” referring to the range of data file second cell
The result of those formulas should then be to have the actual seen values in those two cells as:
MainFileDataIn.JPG : https://imgur.com/vQlhedZ
_____ Workbook: Main.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1dataA1dataB1
Worksheet: Tabelle1
( I have determined that, contrary to much literature, you can actually access a named range from anywhere as long as you include the full path and full string range name: the so called “scope” only determines the default path that Excel uses if you only give the string range name )

_._____________________
Demo Code:
(This code is in File: “Main.xls” )
With all the files in the same Folder, this code can be used to make the two named range Name objects. ( I put one named range Name object in the first worksheet of the file: “ClsdData.xls” and the other named range Name object in the first worksheet of the file: “NameObjectFile.xls” ).
The code also tries to access the first two cells values from the closed workbook using named ranges in these two code lines: The code lines put in those two long named range reference formulas

'_1
Workbooks("Main.xls").Worksheets.Item(1).Range("A1").Value = "='" & ThisWorkbook.Path & "\[ClsdData.xls]DataSht_1'!NameForDataSht_1A1"
and

'_2
Workbooks("Main.xls").Worksheets.Item(1).Range("B1").Value = "='" & ThisWorkbook.Path & "\[NameObjectFile.xls]NameObjectsSht_1'!NameForDataSht_1B1".
Those are the two things I am trying to do.
That last code line fails.
That last code line does not fail if I have the workbook “NameObjectFile.xls” open
Full Code:
Sub Make2NamedRangeObjectsAndTryToUseEm()
' scope named range to first worksheet's collection of Name objects object of Workbook "ClsdData.xls"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "ClsdData.xls"
'Let Workbooks("ClsdData.xls").Worksheets.Item(1).Name = "DataSht_1"
Workbooks("ClsdData.xls").Worksheets("DataSht_1").Names.Add Name:="NameForDataSht_1A1", RefersTo:=Workbooks("ClsdData.xls").Worksheets("DataSht_1").Range("A1")
Workbooks("ClsdData.xls").Close savechanges:=True ' Save Added name object
'_1 access first cell in closed data workbook from main file using named range name object with string name "NameForDataSht_1A1
Let Workbooks("Main.xls").Worksheets.Item(1).Range("A1").Value = "='" & ThisWorkbook.Path & "\[ClsdData.xls]DataSht_1'!NameForDataSht_1A1"
Workbooks("Main.xls").Save
' scope named range to first worksheet's collection of Name objects object of Workbook "NameObjectFile.xls "
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "NameObjectFile.xls"
'Let Workbooks("NameObjectFile.xls").Worksheets.Item(1).Name = "NameObjectsSht_1"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "ClsdData.xls" ' Needed for RefersTo below
Workbooks("NameObjectFile.xls").Worksheets("NameObjectsSht_1").Names.Add Name:="NameForDataSht_1B1", RefersTo:=Workbooks("ClsdData.xls").Worksheets("DataSht_1").Range("B1")
Workbooks("ClsdData.xls").Close savechanges:=False ' No changes made - was only needed for RefersTo above
Workbooks("NameObjectFile.xls").Close savechanges:=True ' Save Added name object
'_2 access second cell in closed dataworkbook from main file using named range name object with string NameForDataSht_1B1
Let Workbooks("Main.xls").Worksheets.Item(1).Range("B1").Value = "='" & ThisWorkbook.Path & "\[NameObjectFile.xls]NameObjectsSht_1'!NameForDataSht_1B1"

End Sub
_.__________
Let me put again into words what I am doing. I am doing two things:

'_1 This works: I have a closed data workbook, ("ClsdData.xls" ). That has a named range, ( string name is “NameForDataSht_1A1” ) . That name, “NameForDataSht_1A1” , is for the first cell in that closed data workbook, ("ClsdData.xls" ). That named range is scoped to the first worksheet in that closed data file, (closed data workbook, ("ClsdData.xls" ) . In other words, the named range object with string name “NameForDataSht_1A1” is in the first worksheets name objects collection of the closed data workbook ( "ClsdData.xls" ). This named range object with string name “NameForDataSht_1A1” refers to the first cell, A1, in the closed data workbook, ("ClsdData.xls" ).

'_2 This does not work , ( unless file "NameObjectFile.xls" is open ). I am using a file, ( "NameObjectFile.xls" ), only for holding name range objects. It has one named range name object in it which has the string name "NameForDataSht_1B1". This is the name range object for the second cell in the closed data workbook, ("ClsdData.xls" ). In other words, the named range object with string name “NameForDataSht_1B1” is in the first worksheets name objects collection of the workbook “NameObjectFile.xls”. This named range object with string name “NameForDataSht_1B1” refers to the second cell, B1, in the closed data workbook, ("ClsdData.xls" ).

I don’t understand yet why '_2 does not work. I am not totally sure why '_1 does work either.
I guess I don’t really understand exactly what I am doing. I don’t really understand what is really going on in the two cases.

I am thinking that I should be able somehow to get the string reference information that I require , that is to say, for the right hand side of the last equation I have this:
"='" & ThisWorkbook.Path & "\[NameObjectFile.xls]NameObjectsSht_1'!NameForDataSht_1B1"
But somehow I am thinking that I should be able to get the referred to string reference of
"='" & ThisWorkbook.Path & "\ [ClsdData.xls]DataSht_1'!$A$1"

[DocAElstein]

I did this..
Took file “NameObjectFile.xls”,
first save as .xlsx,
then save as .zip ( “NameObjectFile - Kopie.zip” : https://app.box.com/s/ih9k6o7s5f3vkb21jyyso0mcqoh82isb )
and then double click on it and get this: NameObjectFile_xls_xlsx_zip.JPG : https://imgur.com/iAVFSOh




I get stuff like this:
_____ Workbook: Main.xls ( Using Excel 2007 32 bit )

NameObjectsFileAsZipNameObjectsFileAsZip

[Content_Types].xml



NameObjectsFileAsZip\docPropsdocProps

app.xml

core.xml

thumbnail.wmf



NameObjectsFileAsZip\xlxl

styles.xml

workbook.xml



NameObjectsFileAsZip\xl\externalLinksexternalLinks

externalLink1.xml



NameObjectsFileAsZip\xl\externalLinks\_rels_rels

externalLink1.xml.rels



NameObjectsFileAsZip\xl\themetheme

theme1.xml



NameObjectsFileAsZip\xl\worksheetsworksheets

sheet1.xml



NameObjectsFileAsZip\xl\_rels_rels

workbook.xml.rels



NameObjectsFileAsZip\_rels_rels

.rels
Worksheet: NameObjectsFileAsZip

NameObjectsFileAsZip_NameObjectsFileAsZip
_____________________[Content_Types].XML Content Types--xml.jpg . https://imgur.com/n9FQUxR
________________
NameObjectsFileAsZip\docProps_______docProps docProps.JPG : https://imgur.com/SRBBdyg
____________________________________app.XML app xml.JPG : https://imgur.com/qeeWrpm
____________________________________core.XML core xml.JPG : https://imgur.com/jZ3iSo7
____________________________________thumbnail.wmf
________________
NameObjectsFileAsZip\xl_____________xl xl.JPG : https://imgur.com/408pO7A
____________________________________Styles.XML styles xml.JPG : https://imgur.com/71fDgcw
____________________________________Workbook.XML workbook xml.JPG : https://imgur.com/AJ3et9N
________________
NameObjectsFileAsZip\xl\externalLinks___________ex ternalLinks externalLinks.JPG : https://imgur.com/SPj3lZY
________________________________________________ex ternalLink1.XML externalLink1 xml rels.JPG : https://imgur.com/qHnFz7u
________________
NameObjectsFileAsZip\xl\externalLinks\_rels_______ _______rels _ rels.JPG : https://imgur.com/GwEBoFG
__________________________________________________ _______externalLink1.XML.rels externalLink1 xml rels.JPG : https://imgur.com/qHnFz7u
________________
NameObjectsFileAsZip\xl\theme___________________th eme theme.JPG : https://imgur.com/KyceI30

________________________________________________th eme1.XML theme1 xml.JPG : https://imgur.com/hGgsgOQ
________________
NameObjectsFileAsZip\xl\worksheets______________wo rksheets worksheets.JPG : https://imgur.com/D8hqFpr
________________________________________________sh eet1.XML Sheet1 xml.JPG : https://imgur.com/ycxiL62
________________
NameObjectsFileAsZip\xl\_rels____________________r els _ rels.JPG https://imgur.com/u84DcoX

________________________________________________Wo rkbook.XML.rels workbook xml rels.JPG : https://imgur.com/L8fNakM
________________
NameObjectsFileAsZip\_rels___________rels _rels.JPG https://imgur.com/Tahoick
____________________________________.rels rels.jpg . https://imgur.com/pWaSeIo

[DocAElstein]

I took this, “ClsdData.xls” , saved it as “ClsdData.xlsx” ,
then changed it to “ClsdData.zip” ,
closed it,
then double clicked on it and get this:
ClsdDataZip.JPG : https://imgur.com/oUtHu34
I copied all that to one folder,
and put that Folder in another folder:
copied all that to one folder, and put that Folder in another folder.JPG : https://imgur.com/an58FA7
I ran the code Sub DoStuffInFoldersInFolderRecursion() which is in the uploaded version of “Main.xls” , and that gives a Folder and File tree something like this if you select one of the above folders when it asks you to select a Folder:
_____ Workbook: Main.xls ( Using Excel 2007 32 bit )





FolderForClsdDataZipContentsFolderForClsdDataZipCo ntents

[Content_Types].xml



FolderForClsdDataZipContents\docPropsdocProps

app.xml

core.xml

thumbnail.wmf



FolderForClsdDataZipContents\xlxl

sharedStrings.xml

styles.xml

workbook.xml



FolderForClsdDataZipContents\xl\themetheme

theme1.xml



FolderForClsdDataZipContents\xl\worksheetsworkshee ts

sheet1.xml



FolderForClsdDataZipContents\xl\_rels_rels

workbook.xml.rels



FolderForClsdDataZipContents\_rels_rels

.rels
Worksheet: ClsdDataZipTree



'FolderForClsdDataZipContents_FolderForClsdDataZip Contents
'__________________________[Content_Types].XML
'
'FolderForClsdDataZipContents\docProps_______docPr ops docProps.JPG : https://imgur.com/6i1gIK4
'____________________________________________app.X ML app XML.JPG : https://imgur.com/XxiZCL9
'____________________________________________core. XML core XML.JPG : https://imgur.com/BwQxqi6
'____________________________________________thumb nail.wmf
'
'FolderForClsdDataZipContents\xl_____________xl xl.JPG : https://imgur.com/YxJFYV4
'____________________________________________share dStrings.XML sharedStrings XML.JPG : https://imgur.com/7dSdvM6
'____________________________________________Style s.XML Styles XML.JPG : https://imgur.com/whytQOj
'____________________________________________Workb ook.XML Workbook XML.JPG: https://imgur.com/P3G2qNC
'
'FolderForClsdDataZipContents\xl\theme____________ theme theme.JPG : https://imgur.com/Vj2RSyM
'_________________________________________________ theme1.XML theme1 XML.JPG : https://imgur.com/zimRsPL
'
'FolderForClsdDataZipContents\xl\worksheets_______ worksheets worksheets.JPG : https://imgur.com/O8KBgSB
'_________________________________________________ sheet1.XML sheet1 XML.JPG : https://imgur.com/LWVPyXn
'
'FolderForClsdDataZipContents\xl\_rels____________ _rels xl_rels.JPG : https://imgur.com/fwYmQwR
'_________________________________________________ Workbook.XML.rels Workbook XML rels.JPG : https://imgur.com/NOxE816
'
'FolderForClsdDataZipContents\_rels___________rels _rels.JPG : https://imgur.com/RTVajJI
'____________________________________________.rels Dot rels.JPG : https://imgur.com/NOxE816

[DocAElstein]

Summary of info in the XML files for "ClsdData.xls" and "NameObjectFile.xls"

app.xml
"ClsdData.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<Properties xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" xmlns="http://schemas.openxmlformats.org/officeDocument/2006/extended-properties"><TotalTime>0</TotalTime><Application>Microsoft Excel</Application><DocSecurity>0</DocSecurity><ScaleCrop>false</ScaleCrop><HeadingPairs><vt:vector baseType="variant" size="4"><vt:variant><vt:lpstr>Arbeitsblätter</vt:lpstr></vt:variant><vt:variant><vt:i4>1</vt:i4></vt:variant><vt:variant><vt:lpstr>Benannte Bereiche</vt:lpstr></vt:variant><vt:variant><vt:i4>2</vt:i4></vt:variant></vt:vector></HeadingPairs><TitlesOfParts><vt:vector baseType="lpstr" size="3"><vt:lpstr>DataSht_1</vt:lpstr><vt:lpstr>DataSht_1!NameForDataSht_1A1</vt:lpstr><vt:lpstr>DataSht_1!Sht_1A1</vt:lpstr></vt:vector></TitlesOfParts><LinksUpToDate>false</LinksUpToDate><SharedDoc>false</SharedDoc><HyperlinksChanged>false</HyperlinksChanged><AppVersion>12.0000</AppVersion></Properties>
"NameObjectFile.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<Properties xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" xmlns="http://schemas.openxmlformats.org/officeDocument/2006/extended-properties"><TotalTime>0</TotalTime><Application>Microsoft Excel</Application><DocSecurity>0</DocSecurity><ScaleCrop>false</ScaleCrop><HeadingPairs><vt:vector baseType="variant" size="2"><vt:variant><vt:lpstr>Arbeitsblätter</vt:lpstr></vt:variant><vt:variant><vt:i4>1</vt:i4></vt:variant></vt:vector></HeadingPairs><TitlesOfParts><vt:vector baseType="lpstr" size="1"><vt:lpstr>NameObjectsSht_1</vt:lpstr></vt:vector></TitlesOfParts><LinksUpToDate>false</LinksUpToDate><SharedDoc>false</SharedDoc><HyperlinksChanged>false</HyperlinksChanged><AppVersion>12.0000</AppVersion></Properties>

_.________________________________________________ _________________

sharedStrings.XML
"ClsdData.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
-<sst uniqueCount="2" count="2" xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">-<si><t>dataA1</t></si>-<si><t>dataB1</t></si></sst>

"NameObjectFile.xls"
-
_.________________________________________________ _____________________

workbook.xml
"ClsdData.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<workbook xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"><fileVersion rupBuild="4507" lowestEdited="4" lastEdited="4" appName="xl"/><workbookPr defaultThemeVersion="124226" codeName="DieseArbeitsmappe"/><bookViews><workbookView windowHeight="11535" windowWidth="14910" yWindow="30" xWindow="240"/></bookViews><sheets><sheet r:id="rId1" sheetId="1" name="DataSht_1"/></sheets><definedNames><definedName name="NameForDataSht_1A1" localSheetId="0">DataSht_1!$A$1</definedName><definedName name="Sht_1A1" localSheetId="0">DataSht_1!$A$1</definedName></definedNames><calcPr calcId="125725"/></workbook>

"NameObjectFile.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<workbook xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"><fileVersion rupBuild="4507" lowestEdited="4" lastEdited="4" appName="xl"/><workbookPr defaultThemeVersion="124226" codeName="DieseArbeitsmappe"/><bookViews><workbookView windowHeight="11535" windowWidth="14910" yWindow="30" xWindow="240"/></bookViews><sheets><sheet r:id="rId1" sheetId="1" name="NameObjectsSht_1"/></sheets><externalReferences><externalReference r:id="rId2"/></externalReferences><definedNames><definedName name="NameForDataSht_1B1" localSheetId="0">[1]DataSht_1!$B$1</definedName></definedNames><calcPr calcId="125725"/></workbook>


_.________________________________________________ __________________________________________

sheet1.XML
"ClsdData.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<worksheet xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"><sheetPr codeName="Tabelle1"/><dimension ref="A1:B1"/><sheetViews><sheetView workbookViewId="0" tabSelected="1"><selection sqref="B8" activeCell="B8"/></sheetView></sheetViews><sheetFormatPr defaultRowHeight="12" baseColWidth="10"/><sheetData><row r="1" spans="1:2"><c r="A1" t="s"><v>0</v></c><c r="B1" t="s"><v>1</v></c></row></sheetData><pageMargins footer="0.3" header="0.3" bottom="0.78740157499999996" top="0.78740157499999996" right="0.7" left="0.7"/></worksheet>

"NameObjectFile.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<worksheet xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"><sheetPr codeName="Tabelle1"/><dimension ref="A1"/><sheetViews><sheetView workbookViewId="0" tabSelected="1"/></sheetViews><sheetFormatPr defaultRowHeight="12" baseColWidth="10"/><sheetData/><pageMargins footer="0.3" header="0.3" bottom="0.78740157499999996" top="0.78740157499999996" right="0.7" left="0.7"/></worksheet>

_.________________________________________________ _______
Workbook.XML.rels
"ClsdData.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Target="styles.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" Id="rId3"/><Relationship Target="theme/theme1.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme" Id="rId2"/><Relationship Target="worksheets/sheet1.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" Id="rId1"/><Relationship Target="sharedStrings.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings" Id="rId4"/></Relationships>

"NameObjectFile.xls"
<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Target="theme/theme1.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme" Id="rId3"/><Relationship Target="externalLinks/externalLink1.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/externalLink" Id="rId2"/><Relationship Target="worksheets/sheet1.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" Id="rId1"/><Relationship Target="styles.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" Id="rId4"/></Relationships>

[DocAElstein]

Some notes to support other posts: A brief introduction to objects and class objects in VBA

This is to support a Tips and Tutorial on advanced Event coding. ( http://www.excelfox.com/forum/showthread.php/2294-WithEvents-of-Excel-Application-Events ) It is difficult to look at advanced events coding without hitting some fundamental ideas behind objects and class objects in VBA.

This thing, "Tabelle2" , ( https://imgur.com/hHHdxyD ) .._
2114 , _.. could loosely be described as a ""worksheet" object with a code in it"…

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then MsgBox prompt:="You just changed the value in the first cell in worksheet " & Me.Name & " in the Workbook " & Me.Parent.Name
End Sub
Right mouse click Or double click in VBA explorer Project window to get code module.JPG : https://imgur.com/gsz6s2N
That coding results in you getting a simple message if you change the value in the first worksheet cell :
Automatic message after change value in first cell .JPG : https://imgur.com/WFINlbq , https://imgur.com/hHHdxyD

_ The actual object: where what how to get at or change
_ what precisely/ physically any object is, is not precisely defined. Consequently what we actually use, and where, in order to "use" an object is somewhat abstract and can be different at different times or for different purposes. As example, In the code example above we were using the second worksheet in a workbook. That worksheet object could "physically" be described as the spreadsheet we "see" when clicking on the second tab. Writing into cells could be described as using the worksheet object. But you will see that in the simple routine above, we referred to the second worksheet object using ".Me" ( Me.JPG : https://imgur.com/R5nJ4n9 ). This is because the code module and code window shown in the screenshots above is also often considered to be that worksheet object. This should confuse you. The concept is not precise. I think possibly in the last 20 years there were too many people employed in the computer industry who had nothing to do. They may have gone a bit mad in their boredom.

_ Class. Class object
_ If we "go back up" the programming hierarchy from, say a worksheet, then we would often have a class object which could / is sometimes seen as actually physically being a Class code module. So that would be a code module similar "looking" to our worksheet code module, but placed somewhere further "up" the hierarchy. A "Class" in VBA is as vague a concept as most VBA stuff follows the word definition of something along the lines of a blueprint or template or Type.
One could thing of the Class as the instructions, as simple text , on how to build something, and a VBA object could be built following those instructions.
A Variable used for an object will generally need to be declared ( Dimed ) to a specific type, and early on in VBA programming one may have, unknowingly, used a Class without realising it, for example , in code lines like these , the word Range , refers to the class Range
Dim Rng As Range
_ Set Rng=Range("A1")
In general, any object will be of a certain type , and the coding or information needed to use those objects will to a large extent be contained in its class. This may or may not be "see able" or accessible to us: it may or may not have a class code module. Such a code module, if it exists, can , and often is, loosely define as that Class object and which we then may or may not be able to access, see and/ or change:…
Class Class object WorksheetType2.JPG : https://imgur.com/PPUfc2w
Class Class object.JPG : https://imgur.com/3WDRcpU
It is very confusing to try and get a clear picture of this structure in the VBA Project window because Microsoft Excel and Microsoft Excel VBA is a disorganised mess:
On the one hand: We see in the VB Editor VBA Project window the individual worksheet objects modules, but not the Class object module from which they "come".
On the other hand: We can add a Class module , which we see then in the VBA Project window, MakeClass.JPG: https://imgur.com/GoKHDoq , but usually we cannot see the individual objects which we make from that Class.

[Class "WorksheetType2" made by us, seen as module ] _ [Class "Worksheet" made by Microsoft, invisible to us ]
___ [ "ShTyp2_1" ] _ [ __ ] [ _ ] ….. ___________________________ ["Sheet1"] ["Tabelle2"] ["MySheet"] ["Sht_4"]…..

So we could make one of those Classes / class modules , for example from the VB Editor VBA Project window by selecting the appropriate right mouse click option… _..
InsertClassModule.JPG : https://imgur.com/vcZSEAj , https://imgur.com/u1orh81
_.. and change its name to, for example , WorksheetType2 via the VBA Project properties window
NameClass.JPG : https://imgur.com/S6u7Gbf
We could add some simple coding "within that object" to "make that object" , for example a simple "Name" Property.
BuildAClass.JPG : https://imgur.com/4WGRbDC
(There is no significance to what that Name Property for the Class WorksheetType2 is at this stage. For the Class Worksheet the Name property is given further significance due to other coding in the Worksheet Class module which we do not have any access to. )

Class Module, Named by us - "WorksheetType2"

' Class (Modules) : https://www.youtube.com/watch?v=jHa8W52mD1k&index=65&list=PLS7iHfqXNVhK3yzd_4XS5k4zsvnu2mkJC : https://www.youtube.com/watch?v=MjbmsVDnAL0
Public Name As String
We can then use that class "WorksheetType2" in a similar way to which we use the existing class "Worksheet". We even get the options added to the intellisense drop down lists:
SimpleWorksheetNamingCode.jpg : https://imgur.com/5pYovYt
SimpleWorksheetNamingCode .jpg : https://imgur.com/v8ZUVVx
So in any code module, we can now do like:

Sub NameAWsType2()
' Make a Worksheet object
Dim Ws4 As Worksheet
Set Ws4 = Worksheets.Item(4)
' Make a WorksheetType2 object
Dim WsTyp2 As WorksheetType2
Set WsTyp2 = New WorksheetType2
' Name the worksheets
Let Ws4.Name = "Sht_4"
Let WsTyp2.Name = "ShTyp2_1"
' Access the names
MsgBox prompt:=Ws1.Name & vbCrLf & WsTyp2.Name
End Sub
The way that our given name WorksheetType2 is used in coding such as that above, supports the idea that in the case of a Class the code module itself can be thought of as the Class object

Just to help clarify. There will be somewhere "hidden" from us, a Worksheet class module, and that will include a vast amount of coding, some of which will include functions / methods which will be associated with the Worksheet Name Property. I guess if we had access to that it might be dangerous as we might change something that could cause a chaos somewhere, as other things will likely be organised in the Excel we use, based on how that coding is.
The word New "creates" an object (a process called instantiating ).
The internal coding which we have no access to will have created the Worksheets already "existing".
We have to do this instantiating for any objects we create, either
through instancing a Class which we have made, as we are discussing here
or
by accessing other objects not included as default in Excel, often referred to as Binding ( http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques )
As I am not allowed such access to the Worksheet class, I cannot use Set __ = New ___ , I can only assign a variable to the existing object like Set __ = ___

Finally, I try to here to sketch in
_ the "invisible" Class object module for the standard Excel worksheets,
and
_ two object modules for the objects I might "make" from the see able Class object module which we "made" with the coding above
Class Object Mess.JPG : https://imgur.com/r6hrPSK
2116

[Class Worksheet]_ [First worksheet object]
_____________________[Second worksheet object]

_ [Class WorksheetType2 ] __ [First object (ShTyp2_1)]
________________________________[Second object]

Also we have a code module, which is not so often called an object, and a Thisworkbook ( In German DieseArbeitsmappe ) code module usually regarded as an object.

It is a mess because it is a mess. :-)

Here is a special "Excel" file which I have which has 6 worksheets.
It has the Class object modules and object modules for
the Application Excel
and
the worksheets. ( Each worksheet has a Class object with just one worksheet "made" from it )
Alans Full Excel.JPG : https://app.box.com/s/iaozdmu9jhu33wo9r2ntcdhkkz1bwu9g , https://imgur.com/0k2NDVX
2115

[Class ExcelAppThisWorkbook] _ [ThisWorkbook object]

_[ Class Worksheet1 ] ________ [First worksheet object]

_ [Class Worksheet2 ] ________ [Second worksheet object ]

_ [Class Worksheet3 ] ________ [Third worksheet object]

_ [Class Worksheet4 ] ________[ Forth worksheet object]

_ [Class Worksheet5 ] ________ [Fifth worksheet object]

_ [Class Worksheet6 ] ________ [Sixth worksheet object]

_ [Class Worksheet7 ] ________ [Seventh worksheet object]





Ref
http://www.cpearson.com/excel/classes.aspx ( RiP Chip Pearson http://excelmatters.com/2018/04/30/rip-chip-pearson/ )

[DocAElstein]

Code for this post:
http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p242918
















' Leave some lines free above
' http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p242918

Sub WotchaGotInHorizontalClit() 'Examine what is copied to clipboard from a row, and paste it into code module
Rem 0 Test range
Range("A1:C1").Value = Array("A1", "B1", "C1")
Rem 1 Clitbored
Range("A1:C1").Copy
Dim objDataObject As Object ' DataObject Late Binding equivalent ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objDataObject.GetFromClipboard
Dim strIn As String: Let strIn = objDataObject.GetText() 'String of range as held in clitbored
Rem 2 examine string from clitbored
Dim myLenf As Long: Let myLenf = Len(strIn)
Dim cnt As Long
For cnt = 1 To myLenf
Dim Caracter As Variant ' String
Let Caracter = Mid(strIn, cnt, 1)
Dim WotchaGot As String
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then ' Check for normal characters
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & "
Else
Select Case Caracter
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & "
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case """"
Let WotchaGot = WotchaGot & """" & """" & """" & " & "
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
Case Else
WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & "
'Let CaseElse = Caracter
End Select
End If
Next cnt
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & "
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot
Rem 4 paste into code module
On Error Resume Next
ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.AddFromString "Rem " & strIn ' a Rem is added to stop the code module showing red error
Set objDataObject = Nothing
End Sub

'
Sub WotchaGotInCodeWindowHorizontal() ' Examine first line of text in the code module
Rem 1 Put first line from code module into a string
Dim strVonCodMod As String
Let strVonCodMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.Lines(Startline:=1, Count:=1)
Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare)
Rem 2 examine string from code module line 1
Dim myLenf As Long: Let myLenf = Len(strVonCodMod)
Dim cnt As Long
For cnt = 1 To myLenf
Dim Caracter As Variant ' String
Let Caracter = Mid(strVonCodMod, cnt, 1)
Dim WotchaGot As String
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & "
Else
Select Case Caracter
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & "
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case """"
Let WotchaGot = WotchaGot & """" & """" & """" & " & "
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
Case Else
WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & "
'Let CaseElse = Caracter
End Select
End If
Next cnt
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot
Rem 3 clipbored
'3a Put string from first code module line in clipbored
Dim objDataObject As Object '
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText strVonCodMod
objDataObject.PutInClipboard
Set objDataObject = Nothing
'3b paste string from first code module line into worksheet
Range("A1:C1").ClearContents
Paste Destination:=Range("A1")
Rem 4 Delete first line from code module
On Error Resume Next
ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.DeleteLines Startline:=1, Count:=1
End Sub


'
Sub WotchaGotInVirticalClit() ''Examine what is copied to clipboard from a column, and paste it into code module
Rem 0 Test range
Dim WhoRay(1 To 3, 1 To 1) As String: Let WhoRay(1, 1) = "A1": Let WhoRay(2, 1) = "A2": Let WhoRay(3, 1) = "A3"
Let Range("A1:A3").Value = WhoRay
Rem 1 Clipboard
Range("A1:A3").Copy
Dim objDataObject As Object
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.GetFromClipboard
Dim strIn As String: Let strIn = objDataObject.GetText()
Rem 2 Examine string held in clipboard from a copy from a column
Dim myLenf As Long: Let myLenf = Len(strIn)
Dim cnt As Long
For cnt = 1 To myLenf
Dim Caracter As Variant ' String
Let Caracter = Mid(strIn, cnt, 1)
Dim WotchaGot As String
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & "
Else
Select Case Caracter
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & "
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case """"
Let WotchaGot = WotchaGot & """" & """" & """" & " & "
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
Case Else
WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & "
Let CaseElse = Caracter
End Select
End If
Next cnt
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot
Rem 4 Paste stringt from clipboard into top of code module
On Error Resume Next
ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.AddFromString "Rem " & Replace(strIn, vbLf, vbLf & "Rem ", 1, 2, vbBinaryCompare)
Set objDataObject = Nothing
End Sub

Sub WotchaGotInCodeWindowVertical() ' Examins what is held in a code module after pasting in a column froma worksheet
Rem 1 Put first 4 lines from code module into a string
Dim strVonCodMod As String
Let strVonCodMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.Lines(Startline:=1, Count:=4)
Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare)
Rem 2 Examine contents of string
Dim myLenf As Long: Let myLenf = Len(strVonCodMod)
Dim cnt As Long
For cnt = 1 To myLenf
Dim Caracter As Variant ' String
Let Caracter = Mid(strVonCodMod, cnt, 1)
Dim WotchaGot As String
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & "
Else
Select Case Caracter
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & "
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case """"
Let WotchaGot = WotchaGot & """" & """" & """" & " & "
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
Case Else
WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & "
'Let CaseElse = Caracter
End Select
End If
Next cnt
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot
Rem 3 Clipboard
'3a Put string into clipboard
Dim objDataObject As Object '
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText strVonCodMod
objDataObject.PutInClipboard
Set objDataObject = Nothing
'3b Paste into worksheet from clipboard
Paste Destination:=Range("A1")
Rem 4 Delet first 4 rows from code module
On Error Resume Next
ThisWorkbook.VBProject.VBComponents(Me.CodeName).C odeModule.DeleteLines Startline:=1, Count:=4
End Sub

[DocAElstein]

Continued from above....


Sub Pubic_Properly_Let_RngAsString_() ' Examination of a range copied to clipboard, then paste to Private Class code module
Range("A1:C1").Value = Array("A1", "B1", "C1")
Range("A2:C2").Value = Array("A2", "B2", "C2")
Range("A3:C3").Value = Array("A3", "B3", "C3")
Range("A1:C3").Copy
Dim objDataObject As Object
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.GetFromClipboard
Dim strIn As String: Let strIn = objDataObject.GetText()
Dim myLenf As Long: Let myLenf = Len(strIn)
Dim cnt As Long
For cnt = 1 To myLenf
Dim Caracter As Variant ' String
Let Caracter = Mid(strIn, cnt, 1)
Dim WotchaGot As String
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & "
Else
Select Case Caracter
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & "
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case """"
Let WotchaGot = WotchaGot & """" & """" & """" & " & "
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
Case Else
WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & "
End Select
End If
Next cnt
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot: Debug.Print
MsgBox Prompt:=Replace(WotchaGot, "vbLf & ", "vbLf" & vbCrLf, 1, -1, vbBinaryCompare): Debug.Print Replace(WotchaGot, "vbLf & ", "vbLf" & vbCrLf, 1, -1, vbBinaryCompare): Debug.Print
MsgBox Prompt:=Replace(WotchaGot, "vbTab", """ | """, 1, -1, vbBinaryCompare): Debug.Print Replace(WotchaGot, "vbTab", """ | """, 1, -1, vbBinaryCompare): Debug.Print

Let strIn = Replace(strIn, vbTab, " | ", 1, -1, vbBinaryCompare) ' replace tab with |
MsgBox Prompt:=strIn: Debug.Print strIn

Let strIn = "Rem " & Replace(strIn, vbLf, vbLf & "Rem ", 1, 2, vbBinaryCompare) ' add some Rems to prevent red error in code window
Debug.Print
On Error Resume Next
ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.AddFromString strIn
Set objDataObject = Nothing
End Sub

Sub Fumic_Properly_Get_Rng_AsString() ' Paste rworksheet range stored in code modulle back to worksheet
Range("A1:C3").ClearContents
'
Dim strVonCodMod As String
Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.Lines(Startline:=1, Count:=4)
Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare)
Let strVonCodMod = Replace(strVonCodMod, " | ", vbTab, 1, -1, vbBinaryCompare)
Dim objDataObject As Object '
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText strVonCodMod
objDataObject.PutInClipboard
Set objDataObject = Nothing
Paste Destination:=Range("A1")
On Error Resume Next
ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.DeleteLines Startline:=1, Count:=4
End Sub


_.________________________________________________ ______________
Extra Codes For Yassers Normal Excel File, "NormalExcelFile.xlsm" : http://eileenslounge.com/viewtopic.php?f=30&t=31395#p242964

Option Explicit
Private Sub Publics_Probably_Let_RngAsString__() ' Input of range to Private Properties storage
Rem 0 test data range is selection. Select a range before running this code
Dim rngSel As Range: Set rngSel = Selection ' selected range for later reference
Rem 1 Copy range to clipbored
rngSel.Copy
Rem 2 put data currently in clipboard into a string
Dim objDataObject As Object ' DataObject ' This will be for an an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. But it is a DataObject. It has the Methods I need to send to and get text to the Clipboard. ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objDataObject.GetFromClipboard ' The data object has the long text string from the clipboard at this point
'rngSel.ClearContents ' we can't do this here, not sure why??
Dim strIn As String: Let strIn = objDataObject.GetText() ' The string variable, strIn, is given the long string
rngSel.ClearContents ' do this now. (If we did it before, the contents of the clipboard are typically emptied, so that would be poo. I don't know why the clipboard needs to be full still fir the last code line??
Rem 3 manipulate string to substitute vbTab with arbritrary character combination - in next code this will be replaced. We do this because the vbTab is lost when pasting into a code module
Let strIn = Replace(strIn, vbTab, " | ", 1, -1, vbBinaryCompare) ' replacing( in the string , replace vbTab , with " | " , start at first position , replace all occurances , look for an excact case sensitive match as this is qiucker if we don't need to be case insensitive as with option vbTextCompare )
Let strIn = "'_-" & Replace(strIn, vbLf, vbLf & "'_-", 1, -1, vbBinaryCompare) ' add some comment bits to prevent red error in code window
Rem 4 add range data
Let strIn = "'_-Worksheets(""" & rngSel.Parent.Name & """).Range(""" & rngSel.Address & """)" & vbCrLf & strIn ' Add an extra first header line to indicate the worksheet and range used
On Error Resume Next ' I am not quite sure why this is needed
ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.AddFromString strIn ' As far as i know, this adds from the start of the module.
Set objDataObject = Nothing ' This probably is not needed. It upsets Kyle when i do it, but he can take it :-)
End Sub

Private Sub Publics_Probably_Get_Rng__AsString() ' Output of range from Private Properties Storage
Rem 2 get string data form code module Private properties storage
Dim strVonCodMod As String
'2a Range infomation first line
Dim Ws As Worksheet, Rng As Range ' These will be used for the range identification infomation which the next code line gets from the first line in the code module used for the
Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.Lines(Startline:=1, Count:=1) ' First line has the
Let strVonCodMod = Replace(Replace(Replace(strVonCodMod, "'_-Worksheets(""", ""), """).Range(""", " "), """)", "") ' we want to reduce and change like "Worksheets("Sht").Range("A1")" to "Sht A1" so that we can use split to get the Sheet name and the range address strVonCodMod = Replace(strVonCodMod, "'_-Worksheets(""", "") : strVonCodMod = Replace(strVonCodMod, """).Range(""", " ") : strVonCodMod = Replace(strVonCodMod, """)", "")
Set Ws = Worksheets(Split(strVonCodMod)(0)): Set Rng = Ws.Range(Split(strVonCodMod)(1)) ' The returned array from spliting by the space , " " , will have first element (indicie(0)) of like "Sht" and the second element (indicie(1)) of like "A1"
'2b get range data
Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.Lines(Startline:=2, Count:=Rng.Rows.Count + 1) ' We need rows count+1 because there seems to be a last & vbCr & vbLf http://eileenslounge.com/viewtopic.php?f=30&t=31395#p242941
Let strVonCodMod = Replace(strVonCodMod, "'_-", "", 1, -1, vbBinaryCompare) ' remove the '_- Comment bits
Let strVonCodMod = Replace(strVonCodMod, " | ", vbTab, 1, -1, vbBinaryCompare) ' Replace the " | " with a carriage return
Rem 3 Put the string into the clipboard
Dim objDataObject As Object '
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText strVonCodMod
objDataObject.PutInClipboard
Set objDataObject = Nothing
Rem 4 Output range data values to spreadsheet
Ws.Paste Destination:=Rng
Rem 5
On Error Resume Next
ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.DeleteLines Startline:=1, Count:=Rng.Rows.Count + 1 + 1 ' remove the first header row and all data and the extra last row caused by the extra & vbCr & vbLf
End Sub



( XL2020alsm.xlsb https://app.box.com/s/26frr0zzc93q6zsraktove3qypqj714p )

[DocAElstein]

Routine for following excelfox Thread:
http://www.excelfox.com/forum/showthread.php/2295-ExtendingInsensibility-into-Code-modules-Copy-table-contents-to-VBIDE-VB-Editor-code-modules?p=10863#post10863 ...



Sub PubProliferous_Let_RngAsString__() ' Make hardcopy of spreadsheet range to VB Editor insensibly http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p243002
Rem 0 VBA project instantiated VBIDE
Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module
Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodu le ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module
Rem 1 Indicate that this module is being used for text.
If Not Right(VBIDEVBAProj.Name, 4) = "_txt" Then Let VBIDEVBAProj.Name = VBIDEVBAProj.Name & "_txt" ' If Not Right(Me.CodeName, 4) = "_txt" Then Let VBIDEVBAProj.Name = Me.CodeName & "_txt"
Rem 2 Selected range to clipboard
Dim rngSel As Range: Set rngSel = Selection: rngSel.Copy
Dim objDataObject As Object ' DataObject ' This will be for an an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. But it is a DataObject. It has the Methods I need to send to and get text to the Clipboard. ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques
Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objDataObject.GetFromClipboard ' The data object has the long text string from the clipboard at this point
Dim strIn As String: strIn = objDataObject.GetText() 'This gets the test string from the Data Object
' rngSel.ClearContents ' range is cleared after copying table values to clipboard
Rem 3
'3a) replace vbTab with "|" as cell divider to use in the VB editor range value display
Let strIn = Replace(strIn, vbTab, "|") ' : Call WotchaGot(strIn)
'3b) typically the last two "characters" from the text obtained from a spreadsheet range via the clipboard has a last vbCr & vbLf pair. We rely on this in further lines so this is just to be sure
If Not Right(strIn, 2) = vbCr & vbLf Then Let strIn = strIn & vbCr & vbLf ' Typically a last vbcr & vblf is there, and we rely on it, so we make sure here ###
Rem 4 add start and stop info
Let strIn = "'_-" & Format(Date, "DD MM YYYY") & " Worksheets(""" & rngSel.Parent.Name & """).Range(""" & rngSel.Address & """)" & vbCr & vbLf & strIn & "'_- EOF " & Format(Date, "DD MM YYYY") ' Note in last bit I am relying on having a vbcr & vbLf after existing strIn ###
Rem 5 Make array from string using the vbCr & vbLf pair as seperator. This willbe an array of data and the extra start and end rows
Dim SpltRws() As String: Let SpltRws() = Split(strIn, vbCr & vbLf, -1, vbBinaryCompare)
Rem 6 Determination of code module table characteristics
'6a) from split rows array, we can get the number of columns and rows
Dim RwCnt As Long, ClCnt As Long
Let RwCnt = (UBound(SpltRws()) - LBound(SpltRws())) + 1 ' Allow for any base
Dim SpltCls() As String: Let SpltCls() = Split(SpltRws(LBound(SpltRws()) + 1), "|", -1, vbBinaryCompare) ' assume second row is representative of all rows for column number
Let ClCnt = (UBound(SpltCls()) - LBound(SpltCls())) + 1
'6b) The next line is a way to make a free line... Because we give a line number in the argument .insertlines Line:= of greater than the current last line number, then that actual number given bears no relation to the actual line number of the code line at which it will be added. ( The line number of the code I am talking about here is , as defined by, or rather as held internally by, and accessed in code coding, by a sequential integer starting at 1 at the top of the code window and counting by +1 for every successive line/row ) Because we give a line number in the argument .insertlines Line:= of greater than the current last line number, then lines will always be added at the next free line, that is to say one line above the last used line. The actual number we give is irrelevant, for numbers we give which are greater than that of the current last used line in the code module.
VBIDEVBAProj.insertlines Line:=VBIDEVBAProj.countoflines + 9996, String:="" ' An attempt to insert a line anywhere above the last used line will force a new line at the end. So this is how we force a space. (Trying to insert a line anywhere above the last used line won't work.
'6c) Find next free row and last row that we will effectively use
Dim CdTblStt As Long, CdTblStp As Long ' these variables will actual hold our start and end lines, but when used below they actually force a new line by virtual of attempting to insert a line above the current last line
Let CdTblStt = VBIDEVBAProj.countoflines + 1 ' We find that + 1 or more will take us to the next free line. (We can insert below or equal to last used line and then all will be shifted up. If we add to the last line =___.CountOfLines then the last line will shift up. Effectively CdTblStt is the start row as it is one up from the last row. But if we used any number >=1 for the 1 , then the actual start line which we obtain would still be at .countoflines + 1
Let CdTblStp = CdTblStt + RwCnt - 1 ' last row in this code module to be used. In actual fact this nimber is what it will be. Effectively with using this later in our code, we try to insert at one line furthter than the last line. For any attempt at an insert >= .countoflines+1 we actually add a new line at the end.
Rem 7 Add lines from array to to code module , using some string formating http://www.excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings --- Dim TabulatorSyncrenator As String: Let TabulatorSyncrenator = "123456789" ' any lengthed string
'7a) Header
VBIDEVBAProj.insertlines Line:=CdTblStt, String:=SpltRws(LBound(SpltRws()))
'7b) Main looping Start for data rows ===============================
Dim Rws As Long
For Rws = CdTblStt + 1 To CdTblStp - 1 Step 1 ' At each row of data
Dim rvec As Long: Let rvec = -CdTblStt + LBound(SpltRws()) ' This gives the adjustment necerssary to take us from a code module line number to an array indicie in the range rows array, SpltRws(). This works as follows: Our used row number actually forces a new line which has that line number. For the relavant array line number, for example , the first line will need to be the first indicie. For zero base, we need to take off excactly CdTblStt For base 1 iwe need to take off 1 less, so rvec would be -(CdTblStt + 1)
Let SpltCls() = Split(SpltRws(Rws + rvec), "|", -1, vbBinaryCompare) 'Split each data row into data columns
'7c) to allow some formatting, a string is built up from each column/cell value
Dim Cls As Long
For Cls = LBound(SpltCls()) To UBound(SpltCls())
Dim TabulatorSyncrenator As String: Let TabulatorSyncrenator = "123456789" ' any lengthed string will do
LSet TabulatorSyncrenator = Trim(SpltCls(Cls)) ' this cause a number like " 56" to change to "56 " This allows us to have a fixed length format here in the displayed code editor
Dim LineAut As String
Let LineAut = LineAut & " | " & TabulatorSyncrenator ' : Debug.Print LineAut
Next Cls
Let LineAut = Replace(LineAut, " | ", "'_-", 1, 1, vbBinaryCompare) 'Replace first " | " with some sort of 'comment thing
VBIDEVBAProj.insertlines Line:=Rws, String:=LineAut ' Note: you could use any from and including one more than the last current line. - effectively here we always try to go >=+1, we are not really defining the line, but just making sure that we add on to the end. Effectively the number in the Line:= does become the line where the string is finally. But it is not directly defined by that.
Let LineAut = "" ' Ready for next line use
Next Rws ' End main data rows Loop ==============================
'7d) End row
VBIDEVBAProj.insertlines Line:=CdTblStp, String:=SpltRws(UBound(SpltRws())) ' Note: this line would not go further than last line, so it must be done here ***
End Sub

[DocAElstein]

Routine for following excelfox Thread
http://www.excelfox.com/forum/showthread.php/2295-ExtendingInsensibility-into-Code-modules-Copy-table-contents-to-VBIDE-VB-Editor-code-modules?p=10864#post10864 .....






Sub PubProliferous_Get_Rng__AsString() ' This pastes out all held table range values in this code module
Rem 0 VBA project instantiated VBIDE
Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module
Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodu le ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module
Rem 1 Do it all
Do: Dim EndOFSub As Boolean ' looping while not at End Sub =================================
Do: Dim FOB As Boolean ' looping while in range data ------------------------------
Dim ReedLineIn As String
If ReedLineIn = "" Then ' because there is no code line in the next line we will go to Let ReedLineIn = if the condition "" is met
'for an empty line we do nothing apart from having already deleted it ( for all but the first time here at the code start)
Else ' We are in data or start or stop-----------------|
Dim arrOut As String ' A string for output from clipboard for each found range
If Mid(ReedLineIn, 15, 12) = "Worksheets(""" Then ' we are at backward looping end(start) of data
Let ReedLineIn = Replace(Replace(Mid(ReedLineIn, 27), """).Range(""", " "), """)", "") 'Let ReedLineIn = Mid(ReedLineIn, 27): ReedLineIn = Replace(ReedLineIn, """).Range(""", " ", 1, 1, vbBinaryCompare): ReedLineIn = Replace(ReedLineIn, """)", "", 1, 1, vbBinaryCompare)
'MsgBox ReedLineIn: Debug.Print ReedLineIn ' ' This is particularly useful in developing codes of this nature, as usally step (F8) mode will often fail due to code lines referrencig this code module which trip up the process somehow
Dim Ws As Worksheet, Rng As Range 'variables to use for output range details
Set Ws = Worksheets(Split(ReedLineIn)(0)): Set Rng = Ws.Range(Split(ReedLineIn)(1)) ' The returned array from spliting by the space , " " , will have first element (indicie(0)) of like "Sheet1" and the second element (indicie(1)) of like "$B$1:$D$13"
' Section to prepare data for, and to do, the paste out of a data value range Output preparing section !!
'MsgBox arrOut: Debug.Print arrOut
Let arrOut = Replace(Replace(arrOut, "'_-", ""), " | ", vbTab) ' The "inner" Replace takes out the "'_-" bit at the start of a line, and the "outer" Replace changes the seperator used in the code module " | " for that which appears to be used by Excel to determine a cell "wall" vbTab
'MsgBox arrOut: Debug.Print arrOut
Let arrOut = Replace(arrOut, " ", "", 1, -1, vbBinaryCompare) ' this is intended as a partial solution to removing most of the extra spaces that we added, whilst not removing any intentionally there. You may want to adjust this along with the actual character used to fill in the unused spaces in oder to come up with a better solution to suit specific data types
'MsgBox arrOut: Debug.Print arrOut 'WotchaGot (arrOut) ' routine to examine contents of string
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText arrOut: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard
Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range )
Let arrOut = "" ' Clear the string to allow for collection of next range
If Right(VBIDEVBAProj.Name, 4) = "_txt" Then Let VBIDEVBAProj.Name = Replace(VBIDEVBAProj.Name, "_txt", "", 1, 1, vbBinaryCompare)
Else
' Section to collect the range value data ( If not at the end section of a data range held in the code window like '_- EOF 22 12 2018 )
If Left(ReedLineIn, 8) = "'_- EOF " Then '
' Let FOB = True ' Let FOB = True is not needed, as clearing the string arrOut effectively starts us again afresh
'for last data we do nothing apart from having already deleted it
Else ' from here we are in data collecting/concatanating into string arrOut +++++
Let arrOut = ReedLineIn & vbCr & vbLf & arrOut ' A simple concatenation along with a new line indicator will give a convenient format of the final data range for use in the Output preparing section !! above Note: we build the string "bachwards" with the next line as first and previous lies after it because the code is looping backwards
End If ' we were collecting/concatenating range value data +++++
End If
End If ' we are did stuff in data or start or stop-----|
Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=VBIDEVBAProj.countof lines, Count:=1)
If ReedLineIn = "End Sub" Or ReedLineIn = "End Function" Then
Let EndOFSub = True
Else ' after reading in any line, we delete it, unless it was the End of a routine
VBIDEVBAProj.DeleteLines StartLine:=VBIDEVBAProj.countoflines, Count:=1
End If
Loop While Not EndOFSub = True ' And FOB = False '------------------------------------
'MsgBox Prompt:="In between data ranges": Let FOB = False ' we could do something here to tell us we are in between range, such as count the ranges, and then set FOB back to zero
Loop While EndOFSub = False ' ================================================== ==============
End Sub

[DocAElstein]

Routine for following excelfox Thread
http://www.excelfox.com/forum/showthread.php/2295-ExtendingInsensibility-into-Code-modules-Copy-table-contents-to-VBIDE-VB-Editor-code-modules?p=10865#post10865



Sub TestieCall()
Call PubeProFannyTeas__GLetner("23 12 2018")
End Sub
Sub PubeProFannyTeas__GLetner(ByVal strDte As String)
Rem 0 VBA project instantiated VBIDE
Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module
Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodu le ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module
Rem 1 This code module data range
'1a) get full data range as string
Dim Cnt As Long, Lr As Long, ReedLineIn As String
Let Lr = VBIDEVBAProj.countoflines: Let Cnt = Lr + 1
Do
Let Cnt = Cnt - 1
Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=Cnt, Count:=1)
Loop While Not (Left(ReedLineIn, 7) = "End Sub" Or Left(ReedLineIn, 7) = "End Fun")
If Cnt = Lr Then MsgBox Prompt:="No range data values in code module " & VBIDEVBAProj.Name: Exit Sub
'1b) Complete data region as single string.
Dim strIn As String: Let strIn = VBIDEVBAProj.Lines(StartLine:=Cnt + 1, Count:=Lr - Cnt)
Let strIn = Mid(strIn, 3) ' take off first vbCr & vbLf
'WotchaGot (strIn)
'1c) split into date ranges, get most recent of any dates to match given strDte
Dim DtedRngs() As String: Let DtedRngs() = Split(strIn, vbCr & vbLf & vbCr & vbLf) ' Split range by empty line which is double vbCr & vbLf
'WotchaGot (DtedRngs(0)): Debug.Print: WotchaGot (DtedRngs(1))
For Cnt = UBound(DtedRngs()) To LBound(DtedRngs()) Step -1
'1d)Check for date match, if so the main code working begins
Dim FndDte As String: Let FndDte = Mid(DtedRngs(Cnt), 4, 10) ' looking at like this typical start of a data range, '_-23 12 2018 Wo.... we see that 10 characters from character 4 will give us the date
If FndDte = strDte Then
'MsgBox Prompt:=FndDte
Rem 2 manipulation of found date range
Dim strRng As String: Let strRng = DtedRngs(Cnt)
Let strRng = Mid(strRng, 27) 'takes off up to start of worksheet name... no speacial reason toher than why not? - its not needed anymore
'2a) range info
Dim RngInfo As String: Let RngInfo = Left(strRng, InStr(1, strRng, """)" & vbCr & vbLf, vbBinaryCompare) - 1) ' This gets us at like Tabelle1").Range("$I$2513:$J$2514
Dim ShtName As String, RngAdrs As String
Let ShtName = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(0) ' split above string , using as seperator ").Range(" , into 2 bits , for exact computer binary type compare Then we have first array element (indicie (0)) as the worksheet name and the second array element (indicie (1)) as the range address
Let RngAdrs = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(1) ': Debug.Print ShtName & " " & RngAdrs
Dim Ws As Worksheet, Rng As Range: Set Ws = Worksheets("" & ShtName & ""): Set Rng = Ws.Range(RngAdrs)
'2b) get data value range
Let strRng = Mid(strRng, InStr(1, strRng, vbCr & vbLf, vbBinaryCompare) + 2) ' take off first line & the first vbCr & vbLf
Let strRng = Left(strRng, InStr(1, strRng, "'_- EOF ", vbBinaryCompare) - 1) ' take off last line, ( but leave on the vbCr & vbLf as that seems to typically be on a string from an excel range
'WotchaGot strRng
Let strRng = Replace(strRng, " | ", vbTab, 1, -1, vbBinaryCompare) 'Change code window cell wall seperator for that used by Excel
Let strRng = Replace(strRng, "'_-", "", 1, -1, vbBinaryCompare)
Let strRng = Replace(strRng, " ", "", 1, -1, vbBinaryCompare) ' Bit of bodge to remove my added spaces
'Debug.Print strRng
Rem 3 output to worksheet
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText strRng: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard
Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range )
Exit Sub 'This code only gets the first found range looking from code window bottom
Else ' No matching date found yet, so do nothing but
End If ' go on to
Next Cnt ' next date range ' ( There is no check for no matching date. The code will simple end after all ranges have been looped through.)
End Sub

[DocAElstein]

Code for Yassser here:
http://www.eileenslounge.com/viewtopic.php?f=30&t=31529#p243999



Option Explicit
'I have numbers from 1 to 2319 made in groups in different numbers (in ten groups) as shown in column F
'How can I get random distribution for those group to have the same range of numbers from 1 to 2319
'but in different order and at the same time to have the same number inside each group
'Example
'Group 6 from 1267 - 1489 >> the number inside that group is 223
'Suppose the random choice make this group the first one so the expected result would be 1 - 223
'
'then suppose the second selected group is group 8 which is 1699 - 1938 >> the number inside that group is 240
'So that new group in the expected result would start at 224
'(which is the last number in the previous result and the finish number would be 463
'
'...
'Is it possible to do that in random order?
'
Sub RandomDistribution4Numbers() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim LstGrpStp As Long: Let LstGrpStp = 0 ' last number used at end of random number group
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To UBound(arrSN(), 1), 1 To 1) ' Array for output values
Do ' we loop while we have not yet filled all of the output array, arrGrpsOut()
Dim Rnd1ToUBnd As Long ' For a random array indicie from 1 to the UBound "row" of the input, (and output), arraysd
Randomize: Let Rnd1ToUBnd = Int(UBound(arrSN(), 1) * Rnd) + 1
If arrGrpsOut(Rnd1ToUBnd, 1) = "" Then ' Not yet filled this element in output array, so do the main stuff
Dim OutElsFilled As Long: Let OutElsFilled = OutElsFilled + 1 ' count of number of outup array elements filled
' split F column (arrSN()) numbers to get range of numbers
Dim SpltRng() As String: Let SpltRng() = Split(arrSN(Rnd1ToUBnd, 1), " - ", 2, vbBinaryCompare)
Dim Rng As Long: Let Rng = SpltRng(1) - SpltRng(0) ' Range of numbers
Dim Stt As Long, Stp As Long: Let Stt = LstGrpStp + 1: Let Stp = LstGrpStp + Rng + 1 ' Start and stop of range of numbers
' build output array with the numbers
Let arrGrpsOut(Rnd1ToUBnd, 1) = Stt & " - " & Stp
Let LstGrpStp = Stp ' Last highest used number
Else ' If we come here then our random number must of been for an indicie of an array element already filled - so this probably makes the code a bit inefficient
End If
Loop While OutElsFilled < UBound(arrSN(), 1) ' we loop while we have not yet filled all of the output array, arrGrpsOut(), which is determined by if we did the main stuff as many times as there are elements in the input/Output arrays

Let Ws1.Range("G2").Resize(UBound(arrSN(), 1)).Value = arrGrpsOut
End Sub
'





Sub RandomizeGroups() ' Hans code ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529#p244006
Dim arr As Variant
Dim lb As Long
Dim ub As Long
Dim i As Long
Dim j As Long
Dim tmp As Long
Dim n As Long
Dim idx() As Long
Dim itm() As String
Dim grp() As String
arr = Range("F2:F11").Value
lb = LBound(arr, 1)
ub = UBound(arr, 1)
ReDim idx(lb To ub)
ReDim grp(lb To ub)
For i = lb To ub
idx(i) = i
Next i
For i = lb To ub
j = Application.RandBetween(lb, ub)
tmp = idx(i)
idx(i) = idx(j)
idx(j) = tmp
Next i
n = 1
For i = lb To ub
itm = Split(arr(idx(i), 1), " - ")
grp(idx(i)) = n & " - " & n + itm(1) - itm(0)
n = n + itm(1) - itm(0) + 1
Next i
Range("G2:G11").Value = Application.Transpose(grp)
End Sub


Typical results from my code are shown in column G. ( The code works on the data from column F )

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I

1for illustration
SN
Some expected resultNumber inside Group


2
1
1 - 244
923 - 1166
244


3
2
245 - 448
1 - 204

204


4
3
449 - 750
398 - 699
302


5
4
751 - 1003
1879 - 2131

253


6
5
1004 - 1266
1167 - 1429

263


7
6
1267 - 1489
700 - 922
1 - 223
223


8
7
1490 - 1698
1430 - 1638

209


9
8
1699 - 1938
1639 - 1878
224 - 463
240


10
9
1939 - 2126
2132 - 2319
188


11
10
2127 - 2319
205 - 397

193
Worksheet: Sheet1


here below a few more runs, showing just column G
_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )
Row\Col
G

1



2
591 - 834


3
835 - 1038


4
1502 - 1803


5
2067 - 2319


6
1804 - 2066


7
1279 - 1501


8
382 - 590


9
1039 - 1278


10
194 - 381


11
1 - 193
Worksheet: Sheet1

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )


254 - 497
2076 - 2319
1470 - 1713
638 - 881


498 - 701
517 - 720
1923 - 2126
1 - 204


1174 - 1475
1774 - 2075
705 - 1006
2018 - 2319


1 - 253
264 - 516
264 - 516
1354 - 1606


911 - 1173
1 - 263
1 - 263
882 - 1144


1476 - 1698
1551 - 1773
1247 - 1469
1607 - 1829


702 - 910
1342 - 1550
1714 - 1922
1145 - 1353


1892 - 2131
721 - 960
1007 - 1246
205 - 444


2132 - 2319
1154 - 1341
517 - 704
1830 - 2017


1699 - 1891
961 - 1153
2127 - 2319
445 - 637
Worksheet: Sheet1

[DocAElstein]

'

Sub Populatenumbersfromrangeofnumbers2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional Array for output values.
Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long
For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1)
Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare)
Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc
Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges
Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one
Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut()
ReDim Preserve arrGrpsOut(1 To Rng2)
For Cnt2 = Rng1 To Rng2
Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5
Next Cnt2
Next cnt

Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column
For cnt = 1 To UBound(arrGrpsOut()) - 1
Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1)
Next cnt

Let Ws1.Range("K2").Resize(UBound(arrOut(), 1), 1) = arrOut()
End Sub
Sub Populatenumbersfromrangeofnumbers2_2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("G2:G" & Ws1.Range("G" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional Array for output values.
Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long
For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1)
Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare)
Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc
Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges
Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one
Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut()
ReDim Preserve arrGrpsOut(1 To Rng2)
For Cnt2 = Rng1 To Rng2
Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5
Next Cnt2
Next cnt

Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column
For cnt = 1 To UBound(arrGrpsOut()) - 1
Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1)
Next cnt

Let Ws1.Range("L2").Resize(UBound(arrOut(), 1), 1) = arrOut()
End Sub


_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )


SN
Some expected resultNumber inside Group


1 - 244
1600 - 1843
24411600


245 - 448
700 - 903

20421601


449 - 750
398 - 699
30231602


751 - 1003
1844 - 2096

25341603


1004 - 1266
1144 - 1406

26351604


1267 - 1489
2097 - 2319
1 - 223
22361605


1490 - 1698
189 - 397

20971606


1699 - 1938
904 - 1143
224 - 463
24081607


1939 - 2126
1 - 188
18891608


2127 - 2319
1407 - 1599

193101609




2319111610



121611






131612






141613






151614






161615






171616






181617






191618






201619






211620






221621



231622



241623



251624



261625



271626



281627



291628



301629



311630



321631



331632



341633
Worksheet: Sheet1

FinalKandLColumns.JPG : https://imgur.com/NF6f2vL
2124

[DocAElstein]

Code for suppot of this Thread:
http://eileenslounge.com/viewtopic.php?f=30&t=31540


Sub SpltTests()
Call Splt(1, 244, 1377, 1620)
End Sub
Function Splt(ByVal N1a As Long, ByVal N1b As Long, ByVal N2a As Long, ByVal N2b As Long) As Variant ' Variant as I don't know yet what might be wanted as output
Rem 1 full columns of data - full data arrays
Dim Clm1() As Variant: Let Clm1() = Evaluate("=row(" & N1a & ":" & N1b & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between N a and N b
Dim Clm2() As Variant: Let Clm2() = Evaluate("=row(" & N2a & ":" & N2b & ")")
Rem 2 get total number of arrays needed
Dim En As Long ' We want
Let En = Int(((N1b - N1a) + 1) / 40) + 1
Rem 3a Not so simple maths to get some grouped numbers for top left of output arrays
' I need rows 1,1,1,42,42,42,83, columns 1,4,7,1,4,7,1
Dim ltrEn As String: Let ltrEn = Cltr(En) ' column letter from column number - G in example data
Dim ltrEnPlus3 As String: Let ltrEnPlus3 = Cltr(En + 3)
Dim Rws() As Variant ' row co ordinates of outout arrays
Let Rws() = Evaluate("=Index((int((column(D:" & ltrEnPlus3 & ")-1)/3)),)") ' Evaluate("=Index((int((column(D:J)-1)/3)),)") 'returns {1, 1, 1, 2, 2, 2, 3}
Dim Clms() As Variant ' column co ordinates of output arrays
Let Clms() = Evaluate("=Index((mod(column(A:" & ltrEn & ")-1,3)+1),)") ' Evaluate("=Index((mod(column(A:G)-1,3)+1),)") 'Returns { 1, 2, 3, 1, 2, 3, 1 }
Dim Cnt ' Loop for all data sections ==================================================
For Cnt = 1 To En
Rem 3b Top left for each array
Dim rTL As Long, cTL As Long
Let rTL = ((Rws(Cnt) - 1) * 41) + 1 ' In the looping this will give 1,1,1,42,42,42,83
Let cTL = ((Clms(Cnt) - 1) * 3) + 1 ' In the looping this will give 1,4,7,1,4,7,1
Rem 4 Columns of data for each loop
Dim ClmOut1() As Variant, ClmOut2() As Variant '4a) use Index with arrays to get part of the sections from full data arrays
Let ClmOut1() = Application.Index(Clm1(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 1
Let ClmOut2() = Application.Index(Clm2(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 2
Dim ClmOut1_1(1 To 40, 1 To 1) As Variant, ClmOut2_1(1 To 40, 1 To 1) As Variant ' I need Variant so as to get empty back for last array in loop paste out
Dim Cnt2 As Long '4b) Loop to get convenient for output 2 dimensional 1 column arrays
For Cnt2 = 1 To 40
If IsError(ClmOut1(Cnt2)) Then Exit For ' To stop filling last array for large than top range value
Let ClmOut1_1(Cnt2, 1) = ClmOut1(Cnt2) ' column 1
Let ClmOut2_1(Cnt2, 1) = ClmOut2(Cnt2) ' column 2
Next Cnt2
Rem 5 Output of arrays to worksheet
'5a Title
Dim Tital(1 To 1, 1 To 2) As String: Let Tital(1, 1) = "S1": Let Tital(1, 2) = "S2"
'5b Columns of data
Dim WsRes As Worksheet: Set WsRes = Worksheets("Result")
WsRes.Cells.Item(rTL, cTL).Resize(1, 2).Value = Tital() ' Title
WsRes.Cells.Item(rTL + 1, cTL).Resize(40, 1).Value = ClmOut1_1() ' column 1
WsRes.Cells.Item(rTL + 1, cTL + 1).Resize(40, 1).Value = ClmOut2_1() 'column 2
Erase ClmOut1_1(), ClmOut2_1() ' without doing this out last array will not have any empties in it
Next Cnt ' ================================================== ===========================
End Function

' Column letter http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Function Cltr(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
Do
Let Cltr = Chr(65 + (((lclm - 1) Mod 26))) & Cltr
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.
Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
'Dim arr1_40() As Variant: Let arr1_40() = Evaluate("=column(A:AN)") ' {1, 2, 3 ....40}


_.__________________________

It will take numbers like 1, 244, 1377, 1620 and then give your wanted result (I think, like Hans said, your test data is a bit wrong – check your row 82 should be 83 I think )
The function is hard coded inside for 40 data rows, and 3 columns of Result data, but you could easily adapt that for different numbers
Rem 1 gives the entire 2 columns of results , similar to in some of your last Threads. Full data arrays are got here for the ranges, ( in your example 1 - 244 and 1377 – 1620 )

Rem 2 does some simple maths to get the number of final sections, ( 7 in your example )

Rem 3 does some not so simple maths to get
row and column, Top left indices,
rTL and cTL , of where the output should go. You want
1,1,1,42,42,42,83 and 1,4,7,1,4,7,1

Rem 4 Uses Index( arrIn() , {1,2,3,4 } , 0 ) type stuff that you know about for pulling out part of an array to get the data section columns of data

Rem 5 Pastes out to the worksheet

Alan



Typical Output as seen in the next 2 posts,

[DocAElstein]

First 3 section output after running Sub SpltTests() from last post ( http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10881#post10881 , https://tinyurl.com/yd95w5v2 )

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

1
S1
S2
S1
S2
S1
S2


2
1
1377
41
1417
81
1457


3
2
1378
42
1418
82
1458


4
3
1379
43
1419
83
1459


5
4
1380
44
1420
84
1460


6
5
1381
45
1421
85
1461


7
6
1382
46
1422
86
1462


8
7
1383
47
1423
87
1463


9
8
1384
48
1424
88
1464


10
9
1385
49
1425
89
1465


11
10
1386
50
1426
90
1466


12
11
1387
51
1427
91
1467


13
12
1388
52
1428
92
1468


14
13
1389
53
1429
93
1469


15
14
1390
54
1430
94
1470


16
15
1391
55
1431
95
1471


17
16
1392
56
1432
96
1472


18
17
1393
57
1433
97
1473


19
18
1394
58
1434
98
1474


20
19
1395
59
1435
99
1475


21
20
1396
60
1436
100
1476


22
21
1397
61
1437
101
1477


23
22
1398
62
1438
102
1478


24
23
1399
63
1439
103
1479


25
24
1400
64
1440
104
1480


26
25
1401
65
1441
105
1481


27
26
1402
66
1442
106
1482


28
27
1403
67
1443
107
1483


29
28
1404
68
1444
108
1484


30
29
1405
69
1445
109
1485


31
30
1406
70
1446
110
1486


32
31
1407
71
1447
111
1487


33
32
1408
72
1448
112
1488


34
33
1409
73
1449
113
1489


35
34
1410
74
1450
114
1490


36
35
1411
75
1451
115
1491


37
36
1412
76
1452
116
1492


38
37
1413
77
1453
117
1493


39
38
1414
78
1454
118
1494


40
39
1415
79
1455
119
1495


41
40
1416
80
1456
120
1496


42
S1
S2
S1
S2
S1
S2


43
121
1497
161
1537
201
1577
Worksheet: Result

[DocAElstein]

4, 5, 6 and 7 data section output after running Sub SpltTests() from http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10881#post10881
https://tinyurl.com/yd95w5v2

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

41
40
1416
80
1456
120
1496


42
S1
S2
S1
S2
S1
S2


43
121
1497
161
1537
201
1577


44
122
1498
162
1538
202
1578


45
123
1499
163
1539
203
1579


46
124
1500
164
1540
204
1580


47
125
1501
165
1541
205
1581


48
126
1502
166
1542
206
1582


49
127
1503
167
1543
207
1583


50
128
1504
168
1544
208
1584


51
129
1505
169
1545
209
1585


52
130
1506
170
1546
210
1586


53
131
1507
171
1547
211
1587


54
132
1508
172
1548
212
1588


55
133
1509
173
1549
213
1589


56
134
1510
174
1550
214
1590


57
135
1511
175
1551
215
1591


58
136
1512
176
1552
216
1592


59
137
1513
177
1553
217
1593


60
138
1514
178
1554
218
1594


61
139
1515
179
1555
219
1595


62
140
1516
180
1556
220
1596


63
141
1517
181
1557
221
1597


64
142
1518
182
1558
222
1598


65
143
1519
183
1559
223
1599


66
144
1520
184
1560
224
1600


67
145
1521
185
1561
225
1601


68
146
1522
186
1562
226
1602


69
147
1523
187
1563
227
1603


70
148
1524
188
1564
228
1604


71
149
1525
189
1565
229
1605


72
150
1526
190
1566
230
1606


73
151
1527
191
1567
231
1607


74
152
1528
192
1568
232
1608


75
153
1529
193
1569
233
1609


76
154
1530
194
1570
234
1610


77
155
1531
195
1571
235
1611


78
156
1532
196
1572
236
1612


79
157
1533
197
1573
237
1613


80
158
1534
198
1574
238
1614


81
159
1535
199
1575
239
1615


82
160
1536
200
1576
240
1616


83
S1
S2


84
241
1617


85
242
1618


86
243
1619


87
244
1620


88
Worksheet: Result

[DocAElstein]

Main Routine in support of these Threads Part 1
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=10893#post10893
http://www.eileenslounge.com/viewtopic.php?f=21&t=31572

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

UDF that can change values in cells other than the cell in which the UDF is used
This Tips Thread was inspired by this one posted by Rick Rothstein (https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions))
I have referred to that posting from Rick quite a few times when showing people how to use a UDF to do things with a UDF in cells other than that in which the UDF is, and mostly pretty impressed they have been too. ( Those that weren’t impressed were those that did not believe it and never tried…. )

I finally got around to trying to get my head around this, and here is my take on it. If you are only interested in seeing the working examples, then jump to post 3 (https://excelfox.com/forum/showthread.php/2707-UDF-that-can-change-values-in-cells-other-than-the-cell-in-which-the-UDF-is-used?p=15263&viewfull=1#post15263)

If you are familiar with Ricks ways of doing this, then basically I am using his solutions but just not using the hyperlink. There’s not much more to it then that. I came there from a long winded way which I am discussing in the next post, but the key to it working is based on, or using, the way Rick used the Evaluate within the coding for the UDF that is in the worksheet

_______ Evaluate__ "SomeOtherProcedureToDoAnythingAnywhere(ArgY, __)"


Here again below, the solution a bit more fully: Below is the coding as you would write it in a normal code module , assuming that the Function MainUDF( ) is the UDF which you would use in the usual formula type way in a worksheet cell like __ = MainUDF( )
http://i.imgur.com/58IFQoQ.jpg

___Function MainUDF(__) ' UDF to be used in a worksheet cell like__ = MainUDF(ArgX)
____ ' any coding to do anything not related to changing things in the worksheet in which the UDF is used
____ '
_______ Evaluate__ "SomeOtherProcedureToDoAnythingAnywhere(ArgY, __)"
____ '
____ ' any coding to do anything not related to changing things in the worksheet in which the UDF is used
____ '
___End Function





Simplest Working Example:
The simplest example is something like the following:
Copy both procedures to a normal code module , …_

' Paste both procedures in a normal code module, then type =ChangeNextCell() in any cell followed by Enter
Function ChangeNextCell()
' Call NextCell ' This wont work. We will be on the same dependancy in the called procedure and cell dependancies are already calculated so attempts to access cells will be screwed up
Evaluate "NextCell()" ' The dependance tree is recalculated for the procedure NextCell() which is excecuted from a copy of the procedure not dependant on the spreadsheet update cycle in progress for the excecution of the function ChangeNextCell()
End Function
Sub NextCell()
ActiveCell.Offset(0, 1).Value = "Next cell." ' Excel has a memory of the last Active Cell and does not rely on dependance to the spreadsheet for this macro to run
End Sub
_... then type in any cell the function _ =ChangeNextCell() _ then _ Enter

ChangeNextCell.JPG : http://i.imgur.com/nqHHEfb.jpg https://imgur.com/nqHHEfb
https://i.imgur.com/nqHHEfb.jpg

ChangeNext Cell.JPG : http://i.imgur.com/iAQFUrj.jpg https://imgur.com/iAQFUrj
https://i.imgur.com/iAQFUrj.jpg

Change Next Cell.JPG : http://i.imgur.com/V7Lowxp.jpg https://imgur.com/V7Lowxp
https://i.imgur.com/V7Lowxp.jpg



In the next post some attempt to examine what’s going on. It is not complete; I may need to come back again on this one

[DocAElstein]

Part 2 of Main code.
This coding in this post should be copied diretly under the coding from the last post. Together they form a single routine, the Main routine

(The routine, Public Sub GetElemsText( ) , which is posted in the next post is also required for the Main routine to work )


Rem 3a) Directly
'
'
' Simple text file print out using just result of PageSrc from '2a
Debug.Print PageSrc ' unfortunately you will unlikely be able to view the whole String as it appears too big. Also pasting to a cell will not make it all visible. However if after pasting the .value from the cell is put in a string and that used in place of Pagesrc in the creation of the DOM it does work, so indicating that the data is there, but just not possible for us to "see".
Dim strTextFile As String: Let strTextFile = ThisWorkbook.Path & "\Updates\strTextFile.txt"
Dim HghWyNo2 As Long: Let HghWyNo2 = FreeFile(RangeNumber:=1)
Open strTextFile For Binary As #HghWyNo2
Put #HghWyNo2, 1, PageSrc ' Use Put to write the whole array at once http://www.vb-helper.com/howto_read_write_binary_file.html https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/put-statement
Close HghWyNo2
'
'
'
'Application.Cursor = xlDefault' Restore the cursor to normal.
Rem 3b) Large Object from main made OOP type model object, (HTMLdoc) ( Rem 3b)(i) ) ' Dim Head As Object
'Dim Head As IHTMLElementCollection 'requires Early Binding. getElementsBy___ returns a NodeList which is an interface to the DispHTMLElementCollection which is an internal class that you're not supposed to see/use. It does implement the IHTMLElementCollection though so you can use that.
Dim Head As Object ' Unusually this Large main Object is Dim ed as an Object, ..as you find you cannot Dim it as what its TypeName( ) returns ( or as displayed in the Watch Window ), “DispHTMLElementCollection“ .
Set Head = HTMLdoc.getElementsByTagName("Table") 'This Object is a massive thing again with loads in, but this time it would appear to be the things "tagged" with < table > < /table > which look like the headings of each table I am interested in
Rem 4)(Rem 3b)(ii)) Often we would loop here for each "Table" but in our example we only have one
'Dim oTable As THMLTable ' If we had Early binding, then this would work, because omehow Head has been recognised as a table oTable as HTMLTable.JPG : https://imgur.com/R309JjC , and for ..._
Dim oTable As Object ' _... this table we have typically present in the object ' HTML TableRow count , "column" Count for final Table will need to be calculated, "HTML Cell" count in Entire Table
Dim C As Long, r As Long 'Indicies for getting appropriate Row and HTMLTableCell
'Dim n As Long ' Not needed if only one table so only "1 Loop"
'4b)=== main working would be Outer loop for each Table in many similar routines==============Building Array from HTML Table
'For n = 0 To Head.Length - 1 ' We only have one table so don't need to loop. The word Length in HTML things is often similar to what Count is in many VBA objects
Set oTable = Head(0) ' Somehow Head has been recognised as a table oTable as HTMLTable.JPG : https://imgur.com/R309JjC
'4b(i) Fill variable for dimensions variable for each, one on our case, Main loop
Dim rowCnt As Long: Let rowCnt = oTable.Rows.Length ' "length" / number of rows in this table
Dim colCt As Long: Let colCt = oTable.Cells.Length 'In this object the cells "length" would appear to be the number / count of cells in the entire table
Dim colCnt As Long: Let colCnt = Application.WorksheetFunction.RoundUp((colCt / oTable.Rows.Length), 0) ' 'This rounds up to the nearest avarage row width, that is to say column number in a row ' I thought this did ? colCt \ oTable.Rows.Length
Dim Data() As String 'Array with string element used for output table. Fixed (static) String type for Text.
ReDim Data(0 To rowCnt - 1, 0 To colCnt - 1) 'Output Array, reDimed to table being looked at. ( Hopefully always same column number, might want to hard Code to rowCnt, 11 columns . Because I am using "base" of indicie to start at 0 then I go from 0 to one less than the Count(Length)
'4b(ii) Looping through rows to build output array-----------|
'---Inner loop does at each row, ....
For r = 0 To rowCnt - 1 'Going along the HTML Table rows exactly as pike ' https://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-vba.html#post4026613
'--- .... 'go through each Cell( "column" ) in that row.
For C = 0 To colCnt - 1 'Going along the HTML Table Cells (columns) exactly the same as pike
'4b(ii)a Build Output Array
Call GetElemsText(oTable.Rows(r).Cells(C), Data(r, C)) 'Data(r, c) = oTable.Rows(r).Cells(c).innerText ' pike, kyle type alternative to calling sub
'4b(ii)b "post processing last column of unified units. ' Probably bad place to put this, other than Speed.. checking / changing units
' If C = .....
'
' Else
' End If
Next C
'--- .... 'go to next "Cell" in that table row (next Column we "see" in the table row)
Next r
'--- 'Go to next row in this table----------------------------|
'4b(ii)c Output from Array
Let Range("A1").Resize(UBound(Data(), 1) + 1, UBound(Data(), 2) + 1).Value = Data()
Columns("A:Z").AutoFit
'Next n 'go back with a new item, n in large collection Object(item) to get next object within and start checking that one out.
'Go to the next table====
Set HTMLdoc = Nothing ' If done then when we no longer need it
End Sub '

[DocAElstein]

___Function MainUDF(__) ' UDF to be used in a worksheet cell like__ = MainUDF(ArgX)
____ ' any conventional UDF coding
____ '
_______ Evaluate__ "SomeOtherProcedureToDoAnythingAnywhere(ArgY, __)"
____ '
____ ' any conventional UDF coding
____ '
___End Function

___Sub SomeOtherProcedureToDoAnythingAnywhere (__) ' ____ ' Any conventional procedure
____ ' Any conventional procedure coding
____ ' coding to change other cell values
____ '
____ ' Any conventional procedure coding
___End Sub






What’s going on? Here is my take on it, - how I got the slightly modified version of Rick’s discovery
Back to the start of Rick’s Post (https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions)) : Rick reported a report, which was a report of the discovery that hovering over a hyperlink in a cell ( where the first argument of the hyperlink function was a Function ) caused the firing of the Function
Like this: Put this in a normal module

Function SayHello() ' ' In any cell type something of this form ( You will need to change the path to suit where you have yopur workbook ) =HYPERLINK('F:\Excel0202015Jan2016\ExcelFox\BlogsB ugs\BugsNovelShortTips\UDFinCellChangeOtherCells\U DF to modify other cells.xls'!Module1.SayHello(),"Hover over this cell to say Hello")
' Stop ' This Stop will only work if you navigate to the cell using arrow keys, and then hit Enter
MsgBox prompt:="Hello"
End Function

Now type _ =HYPERLINK(SayHello()) _ in a cell, and then (after hitting Enter) hover over the cell with the mouse
http://i.imgur.com/1zydn98.jpg
http://i.imgur.com/5hlZEbU.jpg
That message box should pop up


Two things struck me as strange about that
_ (i) That its happening, that is to say that hovering over the cell causes the firing of the function
_ (ii) The hyperlink function is accepting a procedure name rather than the string reference to where the hyperlink "goes"

The second, _ (ii) , exposed a few memory locations in my brain releasing some thoughts and previous observations of mine…
I have frequently seen that “exposing an interface”, ( “exposing an interface” : a technical term I have learnt is often applied to physically writing, or using, a full string reference to some object or function ), makes it do the main thing it is designed to "do". “Exposing an interface" in Visual Basic triggering functions allowing us to write some beautiful flowing single line codes. I think this is somehow fundamental to how excel works. There is something very fundamental to the workings of Excel whereby a full reference to a procedure or function will somehow be like "Calling" it into action. I get the feeling that the most work and fundamental writing of Excel was done at the beginning, and apparent advancements like the move from the original Excel 4 macros to VBA is somewhat of a cover up, or wrap up. People a lot smarter than me in computing tell me that Excel VBA is not really Object Oriented Programming Visual Basic, but rather an attempt after Excel version 4 to make it look and work as if it was.
The original Excel 4 macros worked by listing the commands. We can still do that, listing them in a Macro 4 worksheet ( For example from a new excel version worksheet hit Ctrl+F11 to see what happens ! )
We also have the availability of them Excel 4 macro commands via fiddling the using of the named range dialogue box such as to put the macro 4 command in place of where the “applies to” range would be. Then when we reference such a named range from a worksheet, the Excel 4 macro is fired.
Its my belief that functions and procedures, ( which could loosely all be called commands , where the actual command is the function or procedure name ), get “put somewhere” and can be got at in different ways…. This leads me on to the next couple of observations

Some of the other observations I made
_a) Fully referencing.
This was less of a surprise to me and is a direct consequence of my last few ramblings.
I can replace the simple procedure reference to a full macro Run syntax like
=HYPERLINK('F:\AFolderOfMine\AnotherFolderOfMine\T heFolderWithTheFileInIt\UDF to modify other cells.xls'!Module1.SayHello())
( Don’t be surprised if you try that, and Excel reduces it to something of the form
=HYPERLINK('UDF to modify other cells.xls'!Module1.SayHello())
- Excel has a general habit of reducing the full reference to a workbook when that reference is used in the opened workbook of that which the reference is used in )
( You can check the tricky syntax of such procedure run calls, including the argument versions here : https://stackoverflow.com/questions/31439866/multiple-variable-arguments-to-application-ontime/59812342#59812342 )
_b) Strange non Stoping : Dependency tree and decoupling from the worksheet of a run macro.
You will find that you can fire our simple macro both by the passing over the cell with the mouse, as already discussed, but in addition by using the arrow keys to navigate to the cell, then clicking in the formula bar and hitting Enter. That in itself is no surprise. This latter way, using the Enter key triggers the worksheet re calculation, according to various processes governed by things that come under the Heading of Dependency trees.
What might come as a surprise is the following…. Modify the simple macro to include the Stop and/ or click in the margin to make some brown circle stop points
http://i.imgur.com/xc1QiW4.jpg
The latter way, using the Enter , will get you Stoped in the VB Editor. That is still no surprise.
But hover over the cell with the mouse, .. and you won’t get Stopped!
That was less of a surprise for me, but did help me think that the consideration of the Hyperlink function directly is slightly off course, at least to my way of thinking ….._

Dependency tree and decoupling from the worksheet of a run macro.
_....One of my little theories, already touched on briefly, is that procedures generally are held somewhere and how and exactly , ( to the split second ), when they are run is not always the same. ( I used these thoughts before to discover that another apparently impossible thing could be done, - Passing arguments ByRef using Application Run- https://web.archive.org/web/20190816162718/http://excelmatters.com/2017/04/07/passing-arguments-byref-using-run/#comment-205853 )
We mentioned "exposing an interface" triggers functions allowing us to write some beautiful flowing single line codes. To prevent a possible chaos caused by this, Excel has a dependency tree which informs Excel about which cells depend on which others, or equivalently, which cells are precedents for which others. From this tree, Excel constructs a calculation chain. ( Array formulas use this extensively, or rather, the possibility to have them sets the simplest basic structure, and the so called CSE Entry is a way to exclude cells from processes that require a more detailed dependency tree. )..
By examining dependency trees we can find ways to force a reconstruction of the calculation chain, “after the event” , as it were. There are many ways to do this, probably most of them requiring a convoluted workaround like passing memory locations and copying memory blocks.
Simple ways can often be found. For Application Run , Late Binding is a simple workaround.
Although the Hyperlink considerations have slightly distracted me, Rick’s post (https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions)) has shown me something and partially reminded me that Evaluate has more than the ability to process the text string equivalent of a worksheet formula.
It’s rare that Microsoft documentation is on its own helpful, but occasionally there documentation may still contain some snippets, or clues. Form parts of Microsoft documentation on the Evaluate… .."Processes … using the naming convention of Microsoft Excel . " …….
Ricks interest in Evaluate infected me with it a bit, but I only ever used it to return something.
Rick’s post (https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions)) introduced me to the way of using it like
______ Evaluate__ "Process….. using the naming convention of Microsoft Excel "
Its another one of my little theories that using Evaluate will force a reconstruction of the calculation chain removing dependencies on a worksheet, or at least leading them to be in a form of later recalculation. I think this is what we are looking for:
The snag often regarded as leading to the claim that a UDF can only change values in the cell that it is in, is a direct consequence of the way an Excel spreadsheet is updated in the simplest case. In Layman’s terms, “you can’t lift up a rake when your standing on it….”: To aid efficiency a simple UDF is in the simplest calculation change: things are done in something which can approximately regarded as a simple sequential way , ( we may experience it as along columns then down rows ). That simple dependency chain screws us up in trying to change other cell values.
We have already discussed that evaluating a name is a fundamental part at low level of triggering a run. A good thing to try to "remove an awkward worksheet dependence" would be maybe …
__ Evaluate "YouNameIt"

I tried…
Bingo – It works!

Practical example in the next post.

( after those last "Hello" experiments, it might be best to remove or ' comment out that function, as it might interfere with some of the next experiments
Indeed, in general it is a good idea to remove or ' comment out any used test procedures before moving on to other procedures , as occasionally when debugging and testing functions, UDFs can sometimes be fired off erratically or by accident )

Conclusions. What’s going on
I am not sure yet. I only have constant and stable success with changing values. Values are a more fundamental things and are accessible also from closed workbooks using similar reference strings to some discussed here, but the significance of this I am not yet fully clear on. There are parallels to some of my findings with Running of macros and Excel 4 macro commands.
I think it needs a lot of detailed research, including cross referencing in different Excel versions to do this topic full justice.
I will come back to this Thread probably and either edit or post more replies as time goes on.

Ref
https://www.myonlinetraininghub.com/excel-4-macro-functions
https://docs.microsoft.com/en-us/office/client-developer/excel/excel-recalculation
https://www.excelforum.com/excel-programming-vba-macros/1303563-function-sub-exiting-early-except-when-called-from-developer-tab.html#post5265903
https://www.excelforum.com/excel-charting-and-pivots/1131728-trigger-a-macro-or-worksheet-event-with-a-udf.html#post4343285
https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions)




https://superuser.com/questions/602216/how-do-you-write-an-excel-formula-that-will-paste-a-specific-value-in-a-differen
https://stackoverflow.com/questions/41624463/excel-calculation-in-one-cell-result-in-another

[DocAElstein]

This is required for the single Main routine which is posted in two parts in the last two posts


[Code]'2 Alan http://www.excelforum.com/showthread.php?t=1148621&page=3#post4441761
'5 Leith Ross http://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-visual-basic-applications-2.html#post4031122
'10 '....' "This is a recursive procedure to extract text from between an element's start tag and end tag and everything in between. Usually the Calling program will have passed a HTML code ( either from, for example, a .HTML File, a .Tex File, a .txt file, or from a returned such file after a request to a web page) into a Document Object Model. ( DOM ). This somehow organises things in a tree type structure , approximately as like you might see if you carefully indented the HTML code yourself, such that tag pairs were clear to see within tag pairs, each level down as it were. ( a "next level down" is often referred to as a "Child" ). The exact structure is less obvious, but in any case the DOM will have some ordered structure and every constitute part of the code is referred to as an Element. In a simple case most Elements have a start and stop pointed bracket. They are all nodes. Text is usually squeezed in between somewhere within a paired tag set, but is also referred to as a node.
'12 'I think a node is a point, usually a junction point in the tree type structure. Usually before the procedure is run a first time, an Element will have been obtained from the DOM and this is to be passed in the signature line of the procedure, as an Object. VBA then makes a Copy of the procedure and runs that with the given Element.
'15 'The macro will examine this Element Object brought in for a Text Node: If the element .NodeType is not 3 (a text node) then there are possibly child nodes ( Nodes "next down" in a Tree type listing ) that need to examined. The procedure then "Calls itself". In other words the first Copy stops at the Call Point. At the Call point another Copy of the procedure is made and runs in a loop for each child node.
'20 'The next Copy of the macro will again examine the element for a Text Node. If found (If element node type is 3), the text is concatenated with the ElemText String. If this is the ElemText string is empty then ElemText is set to this value. If not then this value is concatenated with any previous text and separated by a tilde character. This character can be used later to parse the text string into the individual strings from each element. The macro will exit the Sub at this point. When this happens, this copy of the macro is "removed from the call stack", in other words it Ends, and the last Copy continues from the Call point at which it was stopped.
Public Sub GetElemsText(ByRef Elem As Object, ByRef ElemText As String) 'It takes an Object, (variable Elem), a HTML Element, or a ( child ) node thereof. (Wiki says "An HTML element is an individual component of an HTML document or web page, once this has been parsed into the Document Object Model. (DOM). HTML is composed of a tree of HTML Elements and other nodes, such as text nodes." May be close to but not excactly what you se by carefully indenting down "Child" levels
'25 Dim strobjElem As String: Let strobjElem = TypeName(Elem)' http://www.excelforum.com/excel-programming-vba-macros/1149427-vba-determine-object-type-from-html-dom-object-put-type-in-string-variable-as-shown-in.html
65 Rem 1) Do we have an Element
70 If Elem Is Nothing Then GoTo LEndSub [color=darkgreen]'If the Object Elem is empty, or rather we are not given one, Then we End

[DocAElstein]

Post 3 of 3 ... 4 ... 5 etc

Here are some simple working examples. I will probably edit and add to them as time goes on. So far I have tried all these macros and get similar results in Excel 2002 2003 2007 2010 2013 in operating systems of XP Vista Windows 7 Windows 10
I will come back to this Thread probably and either edit or post more replies as time goes on.
Any feedback in particular for results in newer Excel versions would be very welcome

(Note: In general it is a good idea to remove or ' comment out any test procedures before moving on to test other procedures, as occasionally when debugging and testing functions, UDFs can sometimes be fired off erratically or by accident )

If you are familiar with Ricks ways of doing this, then basically I am using his solutions but just not using the hyperlink. There’s not much more to it then that. I came there from a long winded way, explained in post #1, but the key to it working is based on, or using, the way Rick used the Evaluate within the coding for the UDF that is in the worksheet

___________ Evaluate "SomeOtherProcedureToDoAnythingAnywhere(Arg _ , _ )"


https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[DocAElstein]

Post to support this Thread:
http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row?p=10888#post10888
_1) This part of Rick’s solution
Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))

I have seen something similar to this before, but it is lost to mankind hidden down in the comment section of a Blog site, Allen Wyatt’s I think…… so its nice that something like this has seen the light of day here…
If I am not mistaken, this non-looping macro should also work...



Sub ThisShouldWork()
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
End Sub



To help simplify the explanation, lets take it that we know our range , ( http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row#post10870 ) so we have LastRow = 40
Two arbitrarily chosen characters, @ and # , are being used to enter into the main formula the LastRow or LastRow +1
Pseudo like we are doing this sort of thing
Replace( “A#” , “#” , “40” ) in order to end up with like “A40”
By inspection of the main formula, and with a bit of eye straining you can probably see where you replace those @ and # with 40 and 41
Just to be sure , running this will get you a nice copy able version of the main formula in the immediate window , ( after running you Hit Ctrl+g from the VB Editor to get the immediate window up):

Sub ThisShouldWork()
Dim LastRow As Long, strEval As String
Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)
'Range("B1:B" & LastRow).FormulaArray = "=" & strEval
Debug.Print strEval 'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))

That did work.JPG : https://imgur.com/01sQ91X

_._______________________-
Before moving on a useful note: It is always useful when developing these formulas to view the string in the Immediate window: That can help with tricky syntaxes : The formula seen on the Immediate window must look like a formula in the same syntax as you would manually type it into a cell. So you can see immediately if you get something wrong , such as an error in the finally seen quotes.
_.__________________________
So we have our final formula:
IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))
The way these formulas appear to work within the Evaluate(“ “) appears to be tapping into an along the columns , down a row, then along the columns… type updating raster to update a worksheet. The available output then seems to be that which encompasses the deepest and widest ranges. It is a ,little bit more complicated than that ( http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp ) , but for our formula we have nice regular equally sized ranges so we are expecting an output of 1 “wide” and 40 “deep”. So for analysis purposes, we can reduce the formula to 40 similar ones.

Lets take the example of the formula for the 13th “down” output ..
IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13&" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))
Clearly we need to look at this data to see what that formula will do, because this data is used in that formula
_____ Workbook: NormanOrrinRickFilter.xlsm ( Using Excel 2007 32 bit )
Row\Col
A

132018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah,


1410006098, 15392.64
Worksheet: Rick

We have some nested IFs , and I find it is always a good idea to break those down so that we can start doing them as Excel or VBA would do them, that is to say from the middle working outwards. I tend to do this in a text editor with a horizontal scroll bar, or in the VB Editor window
Formula in VB Editor as comment.JPG : https://imgur.com/3cjyqSR

So this is what we have, broken down into the constituent IF sections.
( It may be better to copy this and view in your VB Editor in a wide window. I am working from the bottom , upwards )

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))

Examining the first line , I can evaluate the two innermost IFs and reduce the formula to

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )


I will now evaluate some of those SUBSTITUTEs
( Excel Substitute, seems to work similarly to VBA Replace )

' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 )

( I am guessing that 0+ will ensure that a number will not be mistaken as a text )

For the case of the 13th “down” formula the final steps in the evaluation go as follows

' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 )

Here are all the steps together again

' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 )


' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 )

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )


' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))


The final result will appear in the 13th down position of the 40 “deep” array final results for the entire formula evaluation.
If you can view that last summary on a wide window, it should be able to see how the differing results for the other 39 results are achieved from the formula
Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA

_._____

_2 The final part of Rick’s solution is
Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
This uses the VBA SpecialCells Method to get at the cells with nothing in them. Those are then deleted
Explanation:
VBA SpecialCells Method ( https://www.mrexcel.com/forum/excel-questions/21342-xlcelltypesameformatconditions.html , https://docs.microsoft.com/en-us/office/vba/api/excel.range.specialcells ) returns you a range object ( that range object must not be contiguous ( connected ) cells ) consisting of those cells meeting a specific characteristic. We can choose from a number of characteristics. Here we choose xlBlanks , which refers to the characteristic of the cell being empty. So, if we applied that .SpecialCells(xlBlanks) to this range:.._
Row\Col
B

9


10


112018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5


122018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72


132018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64


14


152018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7

_ … then the returned range from that would be Range(“B9:B10,B14”).
If we then apply .Delete to that range then those cells are removed. If you remove a cell via .Delete then initially there is a real hole, like a “black hole” that can’t really exist in a spreadsheet. So Excel might explode or implode, or you would be sucked into that hole , never to return!!! To prevent that happening, Excel shifts all cells to close that hole, ( and adds a new virgin cell at the bottom or right side to fill the indent there caused by the shift. The default Delete option for the direction of that shift is in our case upwards. Hence after applying the .Delete after applying .SpecialCells(xlBlanks) to the above range, ( pseudo like doing something this Range(“B9:B10,B14”).Delete(Shift:=xlUp) ) we will be left with
Row\Col
B

92018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5


102018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72


112018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64


122018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7


13


14

What has happened there is the following: Those empty cells ( which were yellow ) have been removed. Other cells have been shifted up to fill up the “holes” created by the removal
( Rick’s code line actually deletes the EntireRow of that row on which the empty cells are found )

_.______________________________________________

Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA

[DocAElstein]

Simplest Examples: using a UDF to change the values of other cells
Doing a P in a few cells, the number determined by some cell value.
Consider that a number in some arbitrary cell , say A2 , should determine how many cells in column C get a P in them.
In addition , cell D2 should be a message telling you all about it. This latter requirement would be a normal simple use of either a simple formula or a very simple UDF formula in the cell D2
But the requirement of putting a certain number of Ps down column C would normally be regarded as one requiring
_ a complicated array formula, and that formula would need to extend as far down as the likely maximum wanted number of Ps
or
_ the use of VBA, possibly event coding,
or
_ human interaction to manually do a P in some cells.
_
But we can do it with the simple UDF formula which we would use in the cell D2 , if that UDF also uses an
_ Evaluate "ProcedureToPutThePsIn"
code line in it which will set off the procedure with the name _ ProcedureToPutThePsIn
ProcedureToPutThePsIn can be any normal procedure, ( with a few restrictions. )
_
Solution:
Paste these two codes into a normal code module.

' Paste these two codes into a normal code module. The type in cell D2 =PInCells(A2) then hit Enter. If you now type a number into cell A2 then both the procedures above will excecute
Function PInCells(ByVal Rng As Range) As String ' The function can be thought of as a "variable" that gets filled with a string ( below in the last line** ) , so it needs to be of string type
Dim Nmbr As Long: Let Nmbr = Rng.Value ' A typical bit of coding in the UDF
Evaluate "PutInCells(" & Nmbr & ")" ' This is the special Evaluate "ProcedureToPutThePsIn" piece which helps us contradict the falsly held belief thatz
Let PInCells = "You did " & Nmbr & " Ps in column C" ' A typical piece of coding often towards the end in a UDF giving the function "variable" the return values **
End Function
Sub PutInCells(ByVal Nbr As Long) ' This is a simple normal procedure. It takes in a number which it then uses to determing the size of the range to apply a single value to
Stop ' This won't work. it will be ignored
ActiveSheet.Range("C1:C20").ClearContents ' this wont work. it will be ignored
Let ActiveSheet.Range("C1:C20").Value = "" ' this is a workaround to achieve what the last line would normally do
Let ActiveSheet.Range("C1:C" & Nbr & "").Value = "P"
End Sub

Now type in cell D2 =PInCells(A2) and then hit Enter.
Row\ColCDE
1

2=PInCells(A2)

3

If you now type a number into cell A2 then both the procedures above will execute. For example typing 2 in cell A2 you will get
Row\ColABCDE
1P

2
2PYou did 2 Ps in column C

3



Rick’s example (https://excelfox.com/forum/showthread.php/1519-Breaking-the-rules-for-UDF-s-(User-Defined-Functions))
The main difference, ( and the only significant difference in my version of Rick’s coding ) is that here there is no use of the Excel Hyperlink function
Put these macros in a normal code module

' Put these macros in a normal code module. Now put this UDF calling formula, =DoCool(B3) , in a cell, say, C3… The procedure, TooCool(arg , ) , is the one used in the Evaluate "Procedure to do stuff to other cells" code line. That procedure gives us the output in , that is to say changes the cell value of , J3
' The second part of the function below is conventional UDF stuff. The first part is the bit what lets us change values in cells other than that in which our UDF is placed in the worksheet
Function DoCool(ByVal Rng As Range) As String
Rem 1 ' The next code line(s) is the Evaluate "SomeOtherProcedureToDoAnythingAnywhere(Arg _ , _ )" code line
' Evaluate "'" & ThisWorkbook.Path & "\UDF to modify other cells.xls'!Module1.TooCool(" & Rng.Address & ",J3)
'' or
' Evaluate "'UDF to modify other cells.xls'!Module1.TooCool(" & Rng.Address & ",J3)"
'' or
' Evaluate "Module1.TooCool(" & Rng.Address & ",J3)"
'' or
Evaluate "TooCool(" & Rng.Address & ",J3)"
'_---------------------------------------------------------------------
Rem 2 ' Conventional UDF coding below
If Rng.Value < 0 Then
Let DoCool = "Number in " & Rng.Address(RowAbsolute:=False, ColumnAbsolute:=False) & " is less than zero."
Else
Let DoCool = "Number in " & Rng.Address(RowAbsolute:=False, ColumnAbsolute:=False) & " is greater than, or equal to, zero."
End If
End[ Function
'
' The procedure below is a conventional procedure to put something in a cell.
Sub TooCool(ByVal InCell As Range, ByVal PushTo As Range)
Let PushTo.Value = "The square of " & InCell.Value & " (in " & InCell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & ") is " & InCell.Value ^ 2 & "."
End Sub

Now put this UDF calling formula, =DoCool(B3) , in a cell, say, C3 …
The procedure, TooCool(arg , _ ) , is the one used in the
_ Evaluate "Procedure to do stuff to other cells"
code line. That procedure gives us the output in , that is to say changes the cell value of , J3

Row\ColBCD
2

3=DoCool(B3)

4

Row\ColBCDEFGHIJK
2

3Number in B3 is greater than, or equal to, zero.The square of (in B3) is 0.

4

Row\ColBCDEFGHIJK
2

3
-2Number in B3 is less than zero.The square of -2 (in B3) is 4.

4

[DocAElstein]

Continued from last post

In a range evaluate type code line like the one we are considering, Excel VBA seems to do the following ( simplified ) ( refs *** )

Excel will have an output "window" ( this could be considered as an output table or output array ). The dimensions of this will be that rectangle that allows all used ranges in the formula to be fitted in,
There are some complicated ways in which Excel handles the situation of ranges of varying size, ( http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp ) but for a simpler case of all ranges having the same size, ( in terms of "width" and "depth" ) , as we have, Excel VBA will "expand" its "output window" to this sort of thing:


















































































Excel VBA will do its normal "along the columns, down a row, along the columns…" type thing, in any "Evaluation run". In our case this will mean that it does an evaluation at each row, going down the rows. This is what Excel VBA does in order to fill that last window of cells, ( I am just showing the first 7 of 40 similar formulas as the full list is to big to fit in a forum post )

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2," ",""),",","")),IF(LEFT(A1,4)="2018",TRIM(A1&" "&A2),""),IF(LEFT(A1,4)="2018",A1,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A3," ",""),",","")),IF(LEFT(A2,4)="2018",TRIM(A2&" "&A3),""),IF(LEFT(A2,4)="2018",A2,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A4," ",""),",","")),IF(LEFT(A3,4)="2018",TRIM(A3&" "&A4),""),IF(LEFT(A3,4)="2018",A3,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A5," ",""),",","")),IF(LEFT(A4,4)="2018",TRIM(A4&" "&A5),""),IF(LEFT(A4,4)="2018",A4,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A6," ",""),",","")),IF(LEFT(A5,4)="2018",TRIM(A5&" "&A6),""),IF(LEFT(A5,4)="2018",A5,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A7," ",""),",","")),IF(LEFT(A6,4)="2018",TRIM(A6&" "&A7),""),IF(LEFT(A6,4)="2018",A6,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A8," ",""),",","")),IF(LEFT(A7,4)="2018",TRIM(A7&" "&A8),""),IF(LEFT(A7,4)="2018",A7,""))


Excel VBA will effectively make 40 formulas and place in the "output window" the result of the evaluation of those formulas
The full demo code in the next post includes a code line to put in all 40 formulas in an arbitrary 40 "deep" x 1 "wide" range ("J5:J44")






refs ***
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/page3#post10201







https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Some other notes for a Thread post , I forgot where, ignore for now....

Some other notes for a Thread post , I forgot where


Put this coding in a normal code module

Now type the following in any cell , ( other than cell (A2) ) , and hit enter

If this works for you, then in cell A2 you will get the text, Changed by UDF in cell A2


The following information may be difficult for you to understand, but possibly it is useful to include in this Thread for others…
What you are wanting to do is often regarded as impossible. For example, in post #2 , https://www.myonlinetraininghub.com/excel-forum/vba-macros/pass-named-range-to-vba-function#p18256 , Veloria, she did say…. you can't select another cell in a UDF called from a cell ….
More commonly we hear it said…. a UDF can only change values in the cell that it is in ….
That is not true, mostly.
The snag often regarded as leading to the claim that a UDF can only change values in the cell that it is in, is a direct consequence of the way an Excel spreadsheet is updated in the simplest case. In Layman’s terms, “you can’t lift up a rake when your standing on it….”: To aid efficiency a simple UDF is in the simplest calculation change: things are done in something which can approximately regarded as a simple sequential way , ( we may experience it as along columns then down rows ).
We know that **exposing an interface in Visual Basic triggers functions allowing us to write some beautiful flowing single line codes. To prevent a possible chaos caused by this, Excel has a dependency tree which informs Excel about which cells depend on which others, or equivalently, which cells are precedents for which others. From this tree, Excel constructs a calculation chain
By examining dependency trees we can find way to force a reconstruction of the calculation chain, “after the event” , as it were. There are many ways to do this, probably most of them requiring a convoluted workaround like passing memory locations and copying memory blocks.
A few people, Rick Rothstein, for example, have noticed that we can achieve the same very simply by exposing the UDF interface within a simple Hyperlink
=Hyperlink(MyUDF())
It really is as simple as that.

Exploring the working of that in more detail
**Calling macros is linked into range names , and names in general, as we see by one method used to run Excel 4 Macros: Named Ranges and string references path links are synonymous.
Although there is no documentation on this, it is a direct consequence that a function which requires a string reference will also take a name and result in exposing an interface. That’s what’s going on here.
**This is so fundamental to the working of Excel , and cannot be so easily changed, and explains for example, why we still have many novel solutions available to us via Excel 4 Macros. Its unlikely therefore to not work in newer versions, but as a last disclaimer, I should say I have not tested in newer versions.
But I can do, and have done , this consistently in my Excel 2002 to 2013 working on a number of different computers with operating systems from XP to Windows 10
This means that in general something of the following works, and we have no restrictions on our UDF changing values of any cells anywhere
=Hyperlink('C:Mypath\MyWorkbook.xls'!Module1. MyUDF())
Excel is good at guessing what we mean when we miss things out, and so we can , in the practice, reduce that to
=Hyperlink(MyUDF())

Ref
https://www.myonlinetraininghub.com/excel-4-macro-functions
https://docs.microsoft.com/en-us/office/client-developer/excel/excel-recalculation
https://www.excelforum.com/excel-programming-vba-macros/1303563-function-sub-exiting-early-except-when-called-from-developer-tab.html#post5265903
https://www.excelforum.com/excel-charting-and-pivots/1131728-trigger-a-macro-or-worksheet-event-with-a-udf.html#post4343285

_._____________________________-

Let me bring that all back to your specific example.
First you create this UDF

[DocAElstein]

Full demo code to accompany last post:

Option Explicit
Sub ThisShouldWork()
Dim LastRow As Long, strEval As String
Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)
Debug.Print strEval ' Hit Ctrl+g from the VB Editor to get the Immediate window up. 'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))
'This is the spreadsheet equivalent to Rick's Evaluate
Range("B1:B" & LastRow).FormulaArray = "=" & strEval
'This gives a demo of the actual formulas that Excel VBA does
Range("J5:J44").Value = "=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2,"" "",""""),"","","""")),IF(LEFT(A1,4)=""2018"",TRIM(A1&"" ""&A2),""""),IF(LEFT(A1,4)=""2018"",A1,""""))" ' Applying the fixed vector notation (Excel instructed to do that by no $s) will result in the same relative formula. Displayed will be the actual formula ( in the relative form, but that is not important)

' Final solution Rick : http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row?p=10888#post10888
Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
' Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete ' This will mess up now due to my .FormulaArray as you can't delete bits of that
End Sub



' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 )


' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 )

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )


' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))


and here it is again ... in "Ricks Table Code Tags" ( http://www.excelfox.com/forum/showthread.php/1976-Code-Tag-Test-with-Long-Comments?p=10902#post10902 )



Option Explicit
Sub ThisShouldWork()
Dim LastRow As Long, strEval As String
Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)
Debug.Print strEval ' Hit Ctrl+g from the VB Editor to get the Immediate window up. 'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))
'This is the spreadsheet equivalent to Rick's Evaluate
Range("B1:B" & LastRow).FormulaArray = "=" & strEval
'This gives a demo of the actual formulas that Excel VBA does
Range("J5:J44").Value = "=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2,"" "",""""),"","","""")),IF(LEFT(A1,4)=""2018"",TRIM(A1&"" ""&A2),""""),IF(LEFT(A1,4)=""2018"",A1,""""))" ' Applying the fixed vector notation (Excel instructed to do that by no $s) will result in the same relative formula. Displayed will be the actual formula ( in the relative form, but that is not important)

' Final solution Rick : http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row?p=10888#post10888
Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
' Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete ' This will mess up now due to my .FormulaArray as you can't delete bits of that
End Sub



' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 )


' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 )
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 )

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )


' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))



remember to scroll down first to find the scroll bar:
Scroll down to find Ricks Code bar.JPG : https://imgur.com/R3jgXek
2136


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

XXNVCX:;YNXYN

[DocAElstein]

test post in support of this forum question
http://www.eileenslounge.com/viewtopic.php?f=30&t=31691&p=245488#p245485


Yellow is effectively the array fed to a sort routine.
Green is how that array looks like after running the sort routine

_____ Workbook: YassBub.xlsm ( Using Excel 2007 32 bit )


2
10
8
2
16
8
1
10
15
2


8
1
10
15
2
19
6
3
14
13


15
15
10
6
13
13
7
6
15
16


2
17
2
8
3
5
9
11
12
8


15
12
15
4
5
2
10
8
2
16


13
13
6
4
11
15
12
15
4
5


19
6
3
14
13
13
13
6
4
11


5
9
11
12
8
15
15
10
6
13


14
18
18
16
20
2
17
2
8
3


13
7
6
15
16
14
18
18
16
20
Worksheet: Sheet1


_____ Workbook: YassBub.xlsm ( Using Excel 2007 32 bit )


14
2
2.9986
17
1
1.9983


15
6
6.9985
19
1
1.9981


16
3
3.9984
20
1
1.998


17
1
1.9983
14
2
2.9986


18
2
2.9982
18
2
2.9982


19
1
1.9981
16
3
3.9984


20
1
1.998
15
6
6.9985
Worksheet: Sheet1

_____ Workbook: YassBub.xlsm ( Using Excel 2007 32 bit )


15
4
5
15
4
5


6
4
11
6
4
11


3
14
13
3
14
13
Worksheet: Sheet1



Test calling routine : ( called routines in next 2 posts )

Sub TestsStringArray() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31691&p=245488#p245488
Dim arrSel() As Variant
Let arrSel() = Selection.Value
Dim DumDom() As String: ReDim DumDom(0 To UBound(arrSel(), 1) - 1, 0 To UBound(arrSel(), 2) - 1)
Dim rCnt As Long, cCnt As Long
For rCnt = 0 To UBound(arrSel(), 1) - 1
For cCnt = 0 To UBound(arrSel(), 2) - 1
Let DumDom(rCnt, cCnt) = CStr(arrSel(rCnt + 1, cCnt + 1))
Next cCnt
Next rCnt
Call subSort2DArrayMultiElements(DumDom(), "1 2")
' Paste reorganised Array next to the selection
Dim OutRange As Range: Set OutRange = Selection.Offset(0, Selection.Columns.Count)
Let OutRange.Value = DumDom()
End Sub



_____ Workbook: YassBub.xlsm ( Using Excel 2007 32 bit )


Sub
sub
d
Sub
func
h


Sub
func
h
Pub
pub
a


sub
pub
x
func
pub
m


func
pub
m
Pub
pub
p


func
pub
r
func
pub
r


Pub
pub
a
sub
pub
x


Pub
pub
p
Sub
sub
d
Worksheet: Sheet1

[DocAElstein]

SFNSAFSAFS

[DocAElstein]

Routines called by test code , Sub TestsStringArray() , in last post:



Sub subSort2DArrayMultiElements( _
sparray() As String, _
spOrder As String _
)
' Sort an array with TWO dimensions.
' Assume Sort on the 2nd Dimension
' so assumes it IS a 2 Dim array.
' Sort on more than one element.
'
' This uses a merge sort.
' The sort is set up as ascending and not case sensitive.
'
' Use
' subSortMultiElements Array, Order
'
' Ex Order = "1 4 0 3 2".
' Not all elements need be specified.
' Any delimiter may be used.
'

Dim lnglArrayIndex As Long
Dim lnglElements As Long
Dim lnglEndArray As Long
Dim lnglKey As Long
Dim lnglLbound As Long
Dim lnglM As Long
Dim lnglN As Long
Dim lnglNumSortKeys As Long
Dim lnglO As Long
Dim lnglP As Long
Dim lnglPrevKeyCol As Long
Dim lnglThisKeyCol As Long
Dim lnglUBound As Long
Dim lngSubArrayRows As Long
Dim slKeyVal As String
Dim slOrder As String
Dim slOrderArray() As String
Dim slSubArray() As String
Dim slTopKeyVal As String

lnglElements = UBound(sparray, 2)

' Make an Order Array.
slOrder = spOrder

' Delimiter?
' Disappear the numbers.
For lnglN = 0 To 9
slOrder = Replace(slOrder, CStr(lnglN), "")
Next lnglN
slOrder = Trim$(slOrder)

' Should only have the delimiter left.
If Len(slOrder) = 0 Then
slOrderArray = Split(spOrder, " ")
Else
slOrderArray = Split(spOrder, Mid$(slOrder, 1, 1))
End If

lnglNumSortKeys = UBound(slOrderArray) + 1

' Always Sort on the FIRST Key.
lnglKey = CLng(slOrderArray(0))
subArrayMergeSort sparray, lnglKey

' Only one key?
If lnglNumSortKeys = 1 Then

Exit Sub

End If

' Now go through the rest of the keys.
' We extract a series of arrays based on the KEY - 1.
' Any records to sort?
If UBound(slOrderArray) > 0 Then
For lnglN = 1 To lnglNumSortKeys - 1

' Pick up the start Value from Key-1.
lnglPrevKeyCol = slOrderArray(lnglN - 1)
lnglThisKeyCol = slOrderArray(lnglN)

slTopKeyVal = sparray(0, lnglPrevKeyCol)

lnglLbound = 0
lnglUBound = UBound(sparray, 1)

' All the same.
If sparray(lnglUBound, 0) = slTopKeyVal Then
Exit For
End If

lnglArrayIndex = 0
lnglEndArray = UBound(sparray)
Do
lnglLbound = lnglArrayIndex
slTopKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)
Do
If lnglArrayIndex > lnglEndArray Then
Exit Do
End If

slKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)

If slKeyVal <> slTopKeyVal Then

lnglUBound = lnglArrayIndex - 1
Exit Do

End If

lnglArrayIndex = lnglArrayIndex + 1

Loop

' No need to sort if there's only ONE row.
lngSubArrayRows = lnglUBound - lnglLbound
If lngSubArrayRows > 1 Then


' Get those rows.
ReDim slSubArray(lnglUBound - lnglLbound, lnglElements)
lnglP = 0
For lnglM = lnglLbound To lnglUBound
For lnglO = 0 To lnglElements
slSubArray(lnglP, lnglO) = sparray(lnglM, lnglO)
Next lnglO
lnglP = lnglP + 1
Next lnglM

' Sort 'em.
subArrayMergeSort slSubArray, lnglThisKeyCol

' Put 'em back.
lnglP = 0
For lnglM = lnglLbound To lnglUBound
For lnglO = 0 To lnglElements
sparray(lnglM, lnglO) = slSubArray(lnglP, lnglO)
Next lnglO
lnglP = lnglP + 1
Next lnglM

End If

If lnglArrayIndex > lnglEndArray Then
Exit Do
End If

Loop

Next lnglN
End If

' ************************************************** *********************
End Sub

[DocAElstein]

KVKDLDKLJ

[DocAElstein]

Sub subArrayMergeSort( _
ByRef vpArray As Variant, _
ByVal lngpElement As Long, _
Optional vpMirror As Variant, _
Optional ByVal lngpLeft As Long, _
Optional ByVal lngpRight As Long _
)
' http://www.vbforums.com/showthread.php?t=473677
'
' Recurse Merge Sort a TWO Dim array.
'
' Use...
' subMergeSort Array, Element
'
' lngpLeft and lngpRight are 0 at the start.
'
' Sorts on ONE element.
'

Dim blnlRightIsLessThanLeft As Boolean
Dim blnlLeftIsGreaterThanRight As Boolean
Dim blnlIsNumeric As Boolean
Dim lnglLeftStart As Long
Dim lnglMid As Long
Dim lnglOutputStart As Long
Dim lnglRightStart As Long
Dim vlSwap As Variant
Dim lnglCElement As Long
Dim lnglNumElements As Long
Dim vlSwapRow() As Variant

' This is just to gain a tiiiny bit of speed.
If IsNumeric(vpArray(0, lngpElement)) = True Then
blnlIsNumeric = True
Else
blnlIsNumeric = False
End If

lnglNumElements = UBound(vpArray, 2)
ReDim vlSwapRow(lnglNumElements)
If lngpRight = 0 Then
lngpLeft = LBound(vpArray, 1)
lngpRight = UBound(vpArray, 1)
ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements)
End If
lnglMid = lngpRight - lngpLeft

Select Case lnglMid
Case 0

Case 1

' Changed this to make it case insensitive.
' If vpArray(lngpLeft) > vpArray(lngpRight) Then
If blnlIsNumeric = True Then
If CLng(vpArray(lngpLeft, lngpElement)) _
> CLng(vpArray(lngpRight, lngpElement)) _
Then
blnlLeftIsGreaterThanRight = True
Else
blnlLeftIsGreaterThanRight = False
End If
Else
If StrComp( _
vpArray(lngpLeft, lngpElement), _
vpArray(lngpRight, lngpElement), _
vbTextCompare) _
= 1 _
Then
blnlLeftIsGreaterThanRight = True
Else
blnlLeftIsGreaterThanRight = False
End If
End If

If blnlLeftIsGreaterThanRight Then

' SWAP the whole row.
For lnglCElement = 0 To lnglNumElements
vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement)
Next lnglCElement

For lnglCElement = 0 To lnglNumElements
vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement)
Next lnglCElement

For lnglCElement = 0 To lnglNumElements
vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement)
Next lnglCElement

' vlSwap = vpArray(lngpLeft)
' vpArray(lngpLeft) = vpArray(lngpRight)
' vpArray(lngpRight) = vlSwap

End If

Case Else

lnglMid = lnglMid \ 2 + lngpLeft
subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid
subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight

' Merge the resulting halves

lnglLeftStart = lngpLeft ' start of first (left) half
lnglRightStart = lnglMid + 1 ' start of second (right) half
lnglOutputStart = lngpLeft ' start of output (mirror array)

Do

' Changed this to make it case insensitive.
' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then

If blnlIsNumeric = True Then

If CLng(vpArray(lnglRightStart, lngpElement)) _
< CLng(vpArray(lnglLeftStart, lngpElement)) _
Then
blnlRightIsLessThanLeft = True
Else
blnlRightIsLessThanLeft = False
End If
Else
If StrComp( _
vpArray(lnglRightStart, lngpElement), _
vpArray(lnglLeftStart, lngpElement), _
vbTextCompare) = _
-1 _
Then
blnlRightIsLessThanLeft = True
Else
blnlRightIsLessThanLeft = False
End If
End If

If blnlRightIsLessThanLeft Then

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
Next lnglCElement


lnglRightStart = lnglRightStart + 1
If lnglRightStart > lngpRight Then
For lnglLeftStart = lnglLeftStart To lnglMid
lnglOutputStart = lnglOutputStart + 1

' COPY the whole row.
' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
Next lnglCElement

Next
Exit Do
End If
Else

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
Next lnglCElement


lnglLeftStart = lnglLeftStart + 1
If lnglLeftStart > lnglMid Then
For lnglRightStart = lnglRightStart To lngpRight
lnglOutputStart = lnglOutputStart + 1

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
Next lnglCElement

Next

Exit Do
End If
End If

lnglOutputStart = lnglOutputStart + 1

Loop
For lnglOutputStart = lngpLeft To lngpRight

' Swap the complete row.
' vpArray(lnglOutputStart) = vpMirror(lnglOutputStart)
For lnglCElement = 0 To lnglNumElements
vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement)
Next lnglCElement

Next
End Select

' ************************************************** *******************
End Sub

[DocAElstein]

Coding for answer to this Thread
https://www.eileenslounge.com/viewtopic.php?f=30&t=31740

There are two main routines. They both are event routines reacting when the range A2 : A_ last data row is used.
A selection change routine will make the drop down list the first time that a cell is selected.
A value change routine, ( in the next post ) , makes a filtered range containing just columns having the selected value in that selected row

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
This makes a drop down list in column A when a cell is selected ( The range of ordered values needed to fill the drop down lists is made by this routine and it is placed in a worksheet with Name "DataSaladinValagationLists" )
This is briefly how this routine works:
It only does anything for a selection in the A column range.
It only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
The range of data for that row is copied to the clipboard, excluding empty cells . The text held in the clipboard is retrieved.
A row in Excel is held in the clipboard as a string with a vbTab as separator, and this string also has a trailing vbCr & vbLf which we remove. http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p242941
A 1 Dimensional array is made from the retrieved string, strSptInDrpPlop() , and this is used to produce a simple string which only has unique cell values in it. This string is then used to replace the strSptInDrpPlop() contents with unique values
The unique values as well as a leading “-“ and trailing “Blank” are pasted out to the worksheet "DataSaladinValagationLists"



Sub test()
Let Application.EnableEvents = True
Call Worksheet_SelectionChange(Me.Range("A3"))
Let Application.EnableEvents = True
End Sub
' =DataSaladinValagationLists!A2:A3



Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' for initial making of list for drop down
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range.
If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub ' We already have made a drop down list - only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
Rem 2 make drop down list for this row
' 2a) get unique list of all values in row
Let Application.EnableEvents = False
Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy ' The range of data for that row is copied to the clipboard, excluding empty cells
Let Application.EnableEvents = True
Dim Dtaobj As Object ' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ http://www.eileenslounge.com/viewtopic.php?f=30&t=31547#p244124
Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
Let strClip = Left(strClip, Len(strClip) - 2) ' Take off last vbCr & vbLf
Application.CutCopyMode = False ' Clear clipboard, stop screen flicker
Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare) ' a row in Excel is held as a string with a vbTab as seperator. The array made here may contain duplicated cell values
Dim UnEeks As String: Let UnEeks = " " ' this string will have unique cell values only. I need an initial " " to make sure i can check for a number like " 7 " not just "7" as that might get confused with "27"
Dim Cnt As Long
For Cnt = 0 To UBound(strSptInDrpPlop())
If InStr(1, UnEeks, " " & Trim(strSptInDrpPlop(Cnt)) & " ", vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then ' I am not sure yet if the last check is needed.
Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " " ' A similar string to the original retrieved from the clipboard strClip is made with the difference that the seperator is a space and we have no duplicated cell values
Else
End If
Next Cnt
'Let UnEeks = Replace(UnEeks, vbTab, "", 1, -1, vbBinaryCompare) 'remove rogue vbtabs
Let UnEeks = Mid(UnEeks, 2, Len(UnEeks) - 2) ' take off first and last " " ' Left(UnEeks, Len(UnEeks) - 3) ' take off " " & vbCr & vbLf
'Let UnEeks = "-" & " " & UnEeks & "Blanks"
Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare) ' Replace the 1 Dimensional array values with only unique values
' 2b) sort list ( Bubble sort )
Dim Eye As Long, Jay As Long
For Eye = 0 To UBound(strSptInDrpPlop()) - 1 'I want to take the next in the array, starting at the first. The process below should result in the smallest being put at this position, because I go through the rest , the inner Jay loop, and when ever i find something smaller i swap so the smalles comes here
For Jay = Eye + 1 To UBound(strSptInDrpPlop()) ' I now go through comparing with each of the rest, the Jays
If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then ' This is to overcome an extra problem that I have: I have strings, and VBA thinks that "6" is bigger than "35" but it thinks 6 is less than 35
If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current Eye. By the next Eye, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next Eye
Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
Else
End If
Else ' if we have text, then VBA still allows a comparison to sort - like B > A returns True
If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp ' The element being compared with all the rest is bigger, so we swap it. The effect of this is that the smallest in the rest of the list being looked at, ( The Jay loop ) , will finally end up in the current Eye position.
Else
End If
End If
Next Jay
Next Eye
' 2c) paste in values in DataSaladinValagationLists worksheet
With Worksheets("DataSaladinValagationLists")
Let .Range("A" & Target.Row & "").Value = "-" ' ' a leading "-" ,
Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop() ' unique values
Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank" ' ' and trailing "Blank"
End With
' 2d) Make dropdown list
Target.Validation.Delete ' This is only necerssary if a drop down is already there
Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
End Sub
Sub testieCLDoWhile()
Dim testieletter As String
Let testieletter = CLDoWhile(3) ' should return "C"
End Sub
' CLDoWhile is a Function to get column letter from column number
Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
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
'
'



Sub testsort()

Dim df As String, d As String
df = "df"
Dim var
If IsNumeric(df) Then var = CLng(df)
Dim dg As String
dg = "dg"
MsgBox (dg > df) & " " & (dg > d)
MsgBox "7" < "77"
Dim seven As String, seventyseven As String
Let seven = "7": Let seventyseven = "77"
MsgBox seven < seventyseven
If seven < seventyseven Then MsgBox "True"
Dim arrStr(0 To 1) As String
Let arrStr(0) = "7": Let arrStr(1) = "77"
MsgBox arrStr(0) < arrStr(1)
MsgBox "6" < "34" ' FALSE !!!!!!!!!!******************
End Sub

[DocAElstein]

continued from last post.......

Private Sub Worksheet_Change(ByVal Target As Range)
This reacts to changes of values in column A, for example when selecting a value from the drop down list
Initially a "Blank" selection is changed to "" , and if a "-" was given then the original range is restored

The rest of this routine is very similar to the routine here https://www.eileenslounge.com/viewtopic.php?f=30&t=31687&p=245286#p245218 The difference is that we need here now to determine one set of column indices to use in a code line like pseudo the following to get the required filtered range
Output() = Index ( Cells , allRowIndicies , someColumnIndicies)
( The previous example at that link required all columns and 2 sets of some rows for two outputs based on a column having a Y or not )





Sub testieCLDoWhile()
Dim testieletter As String
Let testieletter = CLDoWhile(3) ' should return "C"
End Sub
' CLDoWhile is a Function to get column letter from column number
Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
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
'
'
Sub testieWksChange()
Call Worksheet_Change(Me.Range("A2"))
Let Application.EnableEvents = True ' Just incase it got turned off
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range.
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True
Rem 2 test data range reset
If Target.Value = "-" Then
Let Application.EnableEvents = False
Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value
Let Application.EnableEvents = True
Rem 3 Get indices( column numbers) for required columns, and all row indicies
'3a) indices( column numbers) for required columns
Else ' selected value is a unique value or "" for "Blank"
Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value ' I dont need the first and third column, but it makes it easier to keep track of the correct columns indicie
Dim Cnt As Long
Dim strClms As String: Let strClms = "1 2 " ' For our required columns containing in this row the target selected value
For Cnt = 3 To CntClms ' check columns from 3 for a match to the value in column 1
If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then ' This is indication of wanted column as it contains the value
Let strClms = strClms & Cnt & " "
Else
End If
Next Cnt
Let strClms = Left(strClms, Len(strClms) - 1) ' Take off last " "
Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare)
Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1) ' for {1,2,7,9} = required columns
For Cnt = 0 To UBound(clmsSpt())
Let Clms(Cnt + 1) = clmsSpt(Cnt)
Next Cnt
'3b) all data ro indicies
Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")") ' = {1;2;3;4;5;6;7;8;9;.......... , CntItms} = required rows ( all rows are required )
Rem 4 Output filtered columns
Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms())
Let Application.EnableEvents = False
Me.Cells.ClearContents
Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Application.EnableEvents = True
End If
End Sub


Sub testsort()

Dim df As String, d As String
df = "df"
Dim var
If IsNumeric(df) Then var = CLng(df)
Dim dg As String
dg = "dg"
MsgBox (dg > df) & " " & (dg > d)


End Sub

[DocAElstein]

Simplified coding for yasser
https://eileenslounge.com/viewtopic.php?f=30&t=31740&p=245769#p245769

Coding for worksheet code module for worksheet "Sheet1"

Option Explicit
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub
If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
Rem 2 make drop down list for this row

Let Application.EnableEvents = False
Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy
Let Application.EnableEvents = True
Dim Dtaobj As Object
Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
Let strClip = Left(strClip, Len(strClip) - 2)
Application.CutCopyMode = False
Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare)
Dim UnEeks As String
Dim Cnt As Long
For Cnt = 0 To UBound(strSptInDrpPlop())
If InStr(1, UnEeks, Trim(strSptInDrpPlop(Cnt)), vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then
Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " "
Else
End If
Next Cnt

Let UnEeks = Left(UnEeks, Len(UnEeks) - 1)

Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare)

Dim Eye As Long, Jay As Long
For Eye = 0 To UBound(strSptInDrpPlop()) - 1
For Jay = Eye + 1 To UBound(strSptInDrpPlop())
If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then
If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then
Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
Else
End If
Else
If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
Else
End If
End If
Next Jay
Next Eye

With Worksheets("DataSaladinValagationLists")
Let .Range("A" & Target.Row & "").Value = "-"
Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop()
Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank"
End With

Target.Validation.Delete
Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
End Sub
Function CLDoWhile(ByVal lclm As Long) As String
Dim rest As Long
Do

Let CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
Let lclm = (lclm - (1)) \ 26

Loop While lclm > 0
End Function
Public Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True
Rem 2 test data range reset
If Target.Value = "-" Then
Let Application.EnableEvents = False
Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value
Let Application.EnableEvents = True
Rem 3 Get indices( column numbers) for required columns, and all row indicies

Else
Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value
Dim Cnt As Long
Dim strClms As String: Let strClms = "1 2 "
For Cnt = 3 To CntClms
If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then
Let strClms = strClms & Cnt & " "
Else
End If
Next Cnt
Let strClms = Left(strClms, Len(strClms) - 1)
Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare)
Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1)
For Cnt = 0 To UBound(clmsSpt())
Let Clms(Cnt + 1) = clmsSpt(Cnt)
Next Cnt

Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")")
Rem 4 Output filtered columns
Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms())
Let Application.EnableEvents = False
Me.Cells.ClearContents
Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Application.EnableEvents = True
End If
End Sub





Extra coding to go in normal code module

Option Explicit
Sub Phillip_Filters()
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row
Dim Cnt As Long
Let Application.EnableEvents = False
For Cnt = 2 To Lr
Call Sheet1.Worksheet_SelectionChange(Ws1.Range("A" & Cnt & ""))
Next Cnt
Let Application.EnableEvents = True
End Sub

Sub ClearFilers()
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row
Let Application.EnableEvents = False
Ws1.Range("A2:A" & Lr & "").Validation.Delete
Ws1.Range("A2:A" & Lr & "").ClearContents
Let Application.EnableEvents = True
Worksheets("DataSaladinValagationLists").Cells.ClearContents
End Sub


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Positioning of procedure separation Line in the Visual Basic Development Environmenthttps://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Rotines for this excelfox Thread
http://www.excelfox.com/forum/showthread.php/2302-quot-What%92s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=10943#post10943

This is part 1 of the coding. The second part is in the next post. The second part must be copied directly under this part in the same code module



Option Explicit '
Option Compare Binary ' https://docs.microsoft.com/de-de/dotnet/visual-basic/language-reference/statements/option-compare-statement

Sub TestWtchaGot()
' In the practice we would likely have our string obtained from some method and would have it held in some string variable
Dim strTest As String ' "Pointer" to a "Blue Print" (or Form, Questionnaire 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. Instructions will tell how to do this. Theoretically a special value vbNullString is set to aid in quick checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
Let strTest = Chr(1) & "Hi" & vbCrLf & vbTab & """u."""
Call WtchaGot(strIn:=strTest)
' Call WtchaGot(Chr(1) & "Hi" & vbCrLf & vbTab & """u.""")
End Sub

Sub WtchaGot(ByVal strIn As String)
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make a Temporary Sheet, if not already there, in Current Active Workbook, for a simple list of all characters
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" 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 Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: 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 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim ws As Worksheet '
Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: 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 ' 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
ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' 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
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 20)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg.9VYH-07VTyW9gJV5fDAZNe)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

This is the second part of the coding from the last post

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5 (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg.9f6hAjkC0ct9f8jleOui-u)
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg (https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Coding in support of this excelfox Thread:
llkslksjjsjfaslkjflkajflkjflfjj later sajfsladj


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ- (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I)

[DocAElstein]

Further Examples using the routines from the previous post
mNxbmn<bx<nb




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg)
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ (https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg.9fsvd9zwZii9gMUka-NbIZ)
https://www.youtube.com/watch?v=jdPeMPT98QU (https://www.youtube.com/watch?v=jdPeMPT98QU)
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg (https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg.9fxrOrrvTln9g9wr8mv2 CS)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g96yGbAX 4t)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg.9fz3_oaiUeK9g7lhoX-ar5)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl )
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh)
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2 (https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg.9g9wJCunNRa9gJGhDZ4R I2)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

The last routine, Sub TestieSimpleArraySort(), has a section dupilcated to allow for selection of a final list sorted in Ascending or descending order.
If supplied 0, or , no GlLl argument is given, then the final list should be sorted in Ascending order



' Simplist Sort2
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
End Sub
'
Sub SimpleArraySort2(Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current rOuter. By the this and all next rOuter, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next rOuter.
If GlLl = 0 Then ' We want Ascending list
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' GlLl is not 0 , so presumably we want Descending list
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub



Results for this callind procedure

Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
Call SimpleArraySort
End Sub
'
_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

2cWasB2
32WasB8


3ABWasB3
6WasB7


4AaWasB4AWasB5


5AWasB5AaWasB4


6CWasB6ABWasB3


7
6WasB7bcdeWasB9


8
32WasB8CWasB6


9bcdeWasB9cWasB2
Worksheet: Sorting


Results for this calling procedure

Sub TestieSimpleArraySort2()
Call SimpleArraySort2(732847)
End Sub
'
_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

2cWasB2cWasB2


3ABWasB3CWasB6


4AaWasB4bcdeWasB9


5AWasB5ABWasB3


6CWasB6AaWasB4


7
6WasB7AWasB5


8
32WasB8
6WasB7


9bcdeWasB9
32WasB8
Worksheet: Sorting

[DocAElstein]

A further modification is done to the previous routines so that values that can be seen as numbers are compared as numbers in sorting. This is done so that, for example, a number like 46 would be seen as greater than 7. In previous routines, these would be compared as text values of "46" and "7". In a text comparison, the sort is done initially on the first character so that "4" would be seen as less that "7". ( The second character, "6", in this exampple is not used. A second character would only be used to sort if we had two values such as "46" and "49". In such an example VBA would place "49" above "46" for a text comparison

We find that the VBA Range.Sort Method sees text as text and numbers typically as numbers , and the final purpose of the routines we are developing in the associated main forum Thread is to do somethhing similar to the VBA Range.Sort Method


'
' Simplist Sort3
Sub TestieSimpleArraySort3()
Call SimpleArraySort3(0)
End Sub
'
Sub SimpleArraySort3(Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current rOuter. By the this and all next rOuter, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next rOuter.
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then' If both values are seen to be numeric then this line would probably work, but as "belt and braces" we do the next
If CDbl(arrOut(rOuter, Clm)) > CDbl(arrOut(rInner, Clm)) Then
Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(arrOut(rInner, Clm)) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub


Final comparison results are shown in the next post

[DocAElstein]

The sorted array is displayed in the spreadsheet along side the original range used as test data for the inputted array. ( The yellow highlighted range is that produced by the array sort routine, Sub SimpleArraySort3() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()


Ascending Order

Sub TestieSimpleArraySort3()
Call SimpleArraySort3(0)
End Sub
'

Sub Range_Sort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Rem 1 For demo purposes we will sort a copy of the range
RngToSort.Offset(0, RngToSort.Columns.Count * 2).Clear ' WsS.Columns("E:F").Clear ' CHANGE TO SUIT
RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count * 2)
Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
'RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlDescending, MatchCase:=False
Let RngCopy.Interior.Color = vbGreen
End Sub
_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1


2cWasB2
6WasB7
6WasB7


3ABWasB3
32WasB8
32WasB8


4AaWasB4AWasB5AWasB5


5AWasB5AaWasB4AaWasB4


6CWasB6ABWasB3ABWasB3


7
6WasB7bcdeWasB9bcdeWasB9


8
32WasB8CWasB6cWasB2


9bcdeWasB9cWasB2CWasB6


10
Worksheet: Sorting



Descending Order

Sub TestieSimpleArraySort3()
Call SimpleArraySort3(2246)
End Sub
'

Sub Range_Sort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Rem 1 For demo purposes we will sort a copy of the range
RngToSort.Offset(0, RngToSort.Columns.Count * 2).Clear ' WsS.Columns("E:F").Clear ' CHANGE TO SUIT
RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count * 2)
Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
'RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlDescending, MatchCase:=False
Let RngCopy.Interior.Color = vbGreen
End Sub
_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1


2cWasB2cWasB2cWasB2


3ABWasB3CWasB6CWasB6


4AaWasB4bcdeWasB9bcdeWasB9


5AWasB5ABWasB3ABWasB3


6CWasB6AaWasB4AaWasB4


7
6WasB7AWasB5AWasB5


8
32WasB8
32WasB8
32WasB8


9bcdeWasB9
6WasB7
6WasB7


10
Worksheet: Sorting

[DocAElstein]

'
Sub TestieSimpleArraySort4()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Call SimpleArraySort4(arrTS(), 0)
End Sub


Sub SimpleArraySort4(ByRef arrTS() As Variant, Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
' Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
If CDbl(arrOut(rOuter, Clm)) > CDbl(arrOut(rInner, Clm)) Then
Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(arrOut(rInner, Clm)) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub

[DocAElstein]

Because we are using ByRef , the previous testieing Calling routine can also use the original supplied array, arrTS() , after the main procedure Call , provided that the array taken in at the signature line is that sorted, as that will in effect be the same array and it will reflect the changes done to it.

Pseudo code ByRef ‘ ( Usually default option )
varMyArray = x
_ Call ReferToIt(varMyArray)
Sub ReferToIt(ByRef arr)
_ arr=y ‘ This is similar to saying varMyArray = y
End
varMyArray is now = y ‘ because effectively varMyArray was in arr


'
Sub TestieSimpleArraySort4b()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Call SimpleArraySort4b(arrTS(), 0)
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub

Sub SimpleArraySort4b(ByRef arsRef() As Variant, Optional ByVal GlLl As Long)
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arsRef(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arsRef(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
End Sub

[DocAElstein]

In the routines
Sub TestieSimpleArraySort5() and Function SimpleArraySort5(______) As Variant
below , the main difference over the previous routines is the extra As Variant at the signature line, and finally a code line just before End Function of SimpleArraySort5 = arsRef()

In the testieing routine, we use codes line of this form in the conventional way in which a function is typically used.
_ arrTS() = SimpleArraySort5(arrTS(), _ 0 _ )
But we note that by virtue of using ByRef a simple call would surfice
_Call SimpleArraySort5(arrTS(), _ 0 _ )

Note: we have added an extra testing code section '2b)
In this extra section we fill a new array, arrDesc() , with the sorted array in Descending order. We use for demo purposes a typical function using code line
_ arrDesc() = SimpleArraySort5(arrTS(), 2136)
Correspondingly we have a demo output giving code line
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()

We note further, that this is somewhat redundant. This is because the code part SimpleArraySort5(arrTS(), 2136) has the effect of re filling arrTS() with the newly sorted array by virtue of the use of ByRef in the signature line of the Function
We could therefore simply use a code line like _..
_Call SimpleArraySort5(arrTS(), 357)
_.. followed by an demo output giving line of
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS()




Sub TestieSimpleArraySort5()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Call SimpleArraySort5(arrTS(), 0)
Let arrTS() = SimpleArraySort5(arrTS(), 0)
Rem 2 Output for easy of demo
' 2a) Ascending
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
' 2b) Descending ( using diiffernet variable )
Dim arrDesc() As Variant
Let arrDesc() = SimpleArraySort5(arrTS(), 2136)
RngToSort.Offset(0, RngToSort.Columns.Count * 3).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS() ' Because we use ByRef this would work after any normal Call of SimpleArraySort5(arrTS(), ) The actual call we use puts the sorted array in arrTS() The important bit is SimpleArraySort5(arrTS(), ) After this arrTS() with the newly sorted array by virtue of the use of ByRe in the signature line of this Function has the effect of refilling arrTS() with the newly sorted in descending order values
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Interior.Color = vbYellow
End Sub

Function SimpleArraySort5(ByRef arsRef() As Variant, Optional ByVal GlLl As Long) As Variant
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arsRef(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arsRef(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Let SimpleArraySort5 = arsRef()
End Function


In the next post are some typical test results for the above coding

[DocAElstein]

Some typical resullts using the coding from the last post

Consider this test input range

_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1


2cWasB2


3ABWasB3


4AaWasB4


5AWasB5


6CWasB6


7
6WasB7


8
32WasB8


9bcdeWasB9


10
Worksheet: Sorting




After running Sub TestieSimpleArraySort5() , you should see this:

_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1


2cWasB2
6WasB7CWasB6


3ABWasB3
32WasB8cWasB2


4AaWasB4AWasB5bcdeWasB9


5AWasB5AaWasB4ABWasB3


6CWasB6ABWasB3AaWasB4


7
6WasB7bcdeWasB9AWasB5


8
32WasB8CWasB6
32WasB8


9bcdeWasB9cWasB2
6WasB7


10
Worksheet: Sorting

[DocAElstein]

Take an example,
A list of Foods, their name in first column and a few other things like calories(Kcal) and Salt content in other columns

First I want to sort to group similar products (based on alphabetical order, but ascending or descending is not important) - This will be sorting on column 1 values

Within similar food types, I want to list them in an order of how healthy they might be, ( or at least in the order of least unhealthy ) .
Most important would be order starting with lowest Kcal.
After that for similar products with similar Kcal , we would consider the minimum salt content as likely to be the less unhealthy.

This might be our list
_____ ( Using Excel 2007 32 bit )
Row\Col
R
S
T
U
V
W

22Food ProductWas S22KcalWas U22SaltWas W22


23CrispsWas S23
500Was U23
0.7Was W23


24Beer Was S24
200Was U24
0.1Was W24


25WineWas S25
150Was U25
0.15Was W25


26BeerWas S26
200Was U26
0.07Was W26


27beerWas S27
220Was U27
0.2Was W27


28BeerWas S28
210Was U28
0.06Was W28


29WineWas S29
160Was U29
0.04Was W29


30wiNeWas S30
150Was U30
0.03Was W30


31CrispsWas S31
502Was U31
2Was W31


32Onion RingesWas S32
480Was U32
1Was W32


33Onion RingesWas S33
490Was U33
1.5Was W33


34CrispsWas S34
502Was U34
1.5Was W34


35CRISPSWas S35
500Was U35
1.1Was W35


36WineWas S36
170Was U36
0.1Was W36


37CrispsWas S37
500Was U37
3Was W37
Worksheet: Sorting


Here is a demo Calling test routine


Sub TestieSimpleArraySort6()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("R23:W37")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
' Call SimpleArraySort6(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To RngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs ' For 5 rows , for example we will have " 1 2 3 4 5 " , for 15 rows " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 "
Call SimpleArraySort6(1, arrTS(), strIndcs, " 1 Desc 3 Asc 5 Asc")
Rem 2 Output for easy of demo
' 2a
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
' 2b VBA Range.Sort Method equivalent
Dim TestRngSrt As Range: Set TestRngSrt = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
TestRngSrt.Clear
Let TestRngSrt.Value = RngToSort.Value
TestRngSrt.Sort Key1:=TestRngSrt.Columns("A:A"), order1:=xlDescending, Key2:=TestRngSrt.Columns("C:C"), order2:=xlAscending, Key3:=TestRngSrt.Columns("E:E"), order3:=xlAscending
TestRngSrt.Interior.Color = vbGreen
End Sub
'

That above routine uses the test range R23:W37 above and feeds that to the main recursion routine below in the next post. The demo routine also does the VBA Range.Sort equivalent code line

[DocAElstein]

'
' Main recursion routine below : Bubble Sorting in Arrays using multi columns values for sort criteria
Sub SimpleArraySort6(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have
If (2 * CopyNo) > UBound(Keys()) + 1 Then MsgBox Prompt:="You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
' making an array from the " 3 4 5 6 " string is just for convenience later of getting the upper and lower row numbers
Dim Rws() As String: Let Rws() = Split(Trim(strRws), " ", -1, vbBinaryCompare) ' We take the supplied sequential string 2 3 4 5 6 and make a 1 D array {1, 2, 3....} as it is a bit more conveniant to work with. Actually we only need the start and top numbers so we could do it with stinr manipulation instead
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = Rws(LBound(Rws())) To Rws(UBound(Rws()) - 1) ' For first row indicie to last but one row indicie
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rws(UBound(Rws())) ' from just above left hand through all the rest
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
' Captains Blog, just fo info
Debug.Print " Running Copy " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
' Rem 3 Determine any duplicates in sort column values , and re run the routine to sort them by another column
Let rOuter = Rws(LBound(Rws())) - 1 ' we look for duplicates in the current list, in the loop below we add 1 each time so _ it is necersarry to start 1 before, so that +1 the first time is the start row
Let strRws = "" ' ready for use in duplicate search
Do ' Loop down the last set of sorted rows ************************************************** **|
Let rOuter = rOuter + 1 ' next row number _ it was necersarry to start 1 before, so that +1 the first time is the start row
If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' when we did not have a next duplicate, we may have a few already grouped
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now Rec Call 1" ' This is done for every duplicated value section, except if we have duplicates at the last lines
Call SimpleArraySort6(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If
End If ' this is the end of the stuff in most situations...
' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last list, so now Rec Call 2 (Dups at list end case)" ' Rec Call 2 - only done for duplicates at end of list
Call SimpleArraySort6(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub


Typical results in the next post:

[DocAElstein]

Typical results using coding from last two posts

_____ ( Using Excel 2007 32 bit )
Row\Col
Q
R
S
T
U
V
W
X
Y
Z
AA
AB
AC
AD
AE
AF
AG
AH
AI
AJ

21


22Food ProductWas S22KcalWas U22SaltWas W22


23CrispsWas S23
500Was U23
0.7Was W23wiNeWas S30
150Was U30
0.03Was W30wiNeWas S30
150Was U30
0.03Was W30


24Beer Was S24
200Was U24
0.1Was W24WineWas S25
150Was U25
0.15Was W25WineWas S25
150Was U25
0.15Was W25


25WineWas S25
150Was U25
0.15Was W25WineWas S29
160Was U29
0.04Was W29WineWas S29
160Was U29
0.04Was W29


26BeerWas S26
200Was U26
0.07Was W26WineWas S36
170Was U36
0.1Was W36WineWas S36
170Was U36
0.1Was W36


27beerWas S27
220Was U27
0.2Was W27Onion RingesWas S32
480Was U32
1Was W32Onion RingesWas S32
480Was U32
1Was W32


28BeerWas S28
210Was U28
0.06Was W28Onion RingesWas S33
490Was U33
1.5Was W33Onion RingesWas S33
490Was U33
1.5Was W33


29WineWas S29
160Was U29
0.04Was W29CrispsWas S23
500Was U23
0.7Was W23CrispsWas S23
500Was U23
0.7Was W23


30wiNeWas S30
150Was U30
0.03Was W30CRISPSWas S35
500Was U35
1.1Was W35CRISPSWas S35
500Was U35
1.1Was W35


31CrispsWas S31
502Was U31
2Was W31CrispsWas S37
500Was U37
3Was W37CrispsWas S37
500Was U37
3Was W37


32Onion RingesWas S32
480Was U32
1Was W32CrispsWas S34
502Was U34
1.5Was W34CrispsWas S34
502Was U34
1.5Was W34


33Onion RingesWas S33
490Was U33
1.5Was W33CrispsWas S31
502Was U31
2Was W31CrispsWas S31
502Was U31
2Was W31


34CrispsWas S34
502Was U34
1.5Was W34BeerWas S26
200Was U26
0.07Was W26Beer Was S24
200Was U24
0.1Was W24


35CRISPSWas S35
500Was U35
1.1Was W35Beer Was S24
200Was U24
0.1Was W24BeerWas S26
200Was U26
0.07Was W26


36WineWas S36
170Was U36
0.1Was W36BeerWas S28
210Was U28
0.06Was W28BeerWas S28
210Was U28
0.06Was W28


37CrispsWas S37
500Was U37
3Was W37beerWas S27
220Was U27
0.2Was W27beerWas S27
220Was U27
0.2Was W27


38
Worksheet: Sorting

[DocAElstein]

Code in support of these Threads:


http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques?p=11018#post11018
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849
https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c
https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767



Private Type POINTAPI
x As Long: Y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Dim hwndClip As LongPtr
Dim hwndScrollBar As LongPtr
Dim lngPtr As LongPtr
#Else
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Dim hwndClip As Long
Dim hwndScrollBar As Long
#End If
Const GW_CHILD = 5
Const S_OK = 0

Sub ClearOffPainBouton() 'OhFolloks
'Application.DisplayClipboardWindow = True
Dim tRect1 As RECT, tRect2 As RECT
Dim tPt As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
Dim lResult As Long
Dim i As Long
Static bHidden As Boolean
Dim MyPain As String 'COMsOLEwollupsActivelyEmmbeddedXratedObjectHookMy BoutonOhFolloks
If CLng(Val(Application.Version)) <= 11 Then
Let MyPain = "Task Pane"
Else
Let MyPain = "Office Clipboard"
End If
If CommandBars(MyPain).Visible = False Then
bHidden = True
CommandBars(MyPain).Visible = True
Application.OnTime Now + TimeValue("00:00:01"), "ClearOffPainBouton": Exit Sub
End If

Let hwndClip = FindWindowEx(Application.hWnd, 0, "EXCEL2", vbNullString)
Let hwndClip = FindWindowEx(hwndClip, 0, "MsoCommandBar", CommandBars(MyPain).NameLocal)
Let hwndClip = GetNextWindow(hwndClip, GW_CHILD)
Let hwndScrollBar = GetNextWindow(GetNextWindow(hwndClip, GW_CHILD), GW_CHILD)

If hwndClip And hwndScrollBar Then
GetWindowRect hwndClip, tRect1
GetWindowRect hwndScrollBar, tRect2
BringWindowToTop Application.hWnd
For i = 0 To tRect1.Right - tRect1.Left Step 50
tPt.x = tRect1.Left + i: tPt.Y = tRect1.Top - 10 + (tRect2.Top - tRect1.Top) / 2
#If VBA7 And Win64 Then
CopyMemory lngPtr, tPt, LenB(tPt)
Let lResult = AccessibleObjectFromPoint(lngPtr, oIA, vKid)
#Else
Let lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, vKid)
#End If ' ##### avec moi si vou ple La légende du bouton
If InStr("Clear All Borrar todo Effacer tout Alle löschen La légende du bouton", oIA.accName(vKid)) Then
Call oIA.accDoDefaultAction(vKid): CommandBars(MyPain).Visible = Not bHidden: bHidden = False: Exit Sub
End If
DoEvents
Next i
End If
Let CommandBars(MyPain).Visible = Not bHidden
MsgBox "Unable to clear the Office Clipboard"
End Sub

Sub TestVersion() ' Rory Archibald 2015
MsgBox prompt:=ExcelVersion
MsgBox prompt:=CLng(Val(Application.Version))
End Sub
Private Function ExcelVersion() As String
Dim Temp As String

'On Error Resume Next
#If Mac Then
Select Case CLng(Val(Application.Version))
Case 11: Temp = "Excel 2004"
Case 12: Temp = "Excel 2008" ' this should NEVER happen!
Case 14: Temp = "Excel 2011"
Case 15: Temp = "Excel 2016 (Mac)"
Case Else: Temp = "Unknown"
End Select
#Else
Select Case CLng(Val(Application.Version))
Case 9: Temp = "Excel 2000"
Case 10: Temp = "Excel 2002"
Case 11: Temp = "Excel 2003"
Case 12: Temp = "Excel 2007"
Case 14: Temp = "Excel 2010"
Case 15: Temp = "Excel 2013"
Case 16: Temp = "Excel 2016 (Windows)"
Case Else: Temp = "Unknown"
End Select
#End If
#If Win64 Then
Temp = Temp & " 64 bit"
#Else
Temp = Temp & " 32 bit"
#End If

ExcelVersion = Temp
End Function

[DocAElstein]

Code in support of this Thread
http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques?p=11018&viewfull=1#post11018

In simple terms this clears the Windows Clipboard.
More likely there is an awful lot more to it than that, so I may come back here with a much larger offering in the future.... _
_.. the various Microsoft Clipboards and the versions of copies that hey hold have a spaghetti of interdependencies that anyone has long since given up trying to understand**. Sadly it will probably be left to some later form of artificial intelligence to understand.. and use effectively… against us…. … you are experiencing a car accident…. The hell I am…. https://www.youtube.com/watch?v=qhAFWW-p7PQ......








#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
#Else
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
#End If

Public Function ClearWindowsClipboard()
If OpenClipboard(0&) Then
EmptyClipboard
CloseClipboard
Else
MsgBox "OpenClipboard failed"
End If
End Function

Sub Test()
Call ClearWindowsClipboard
End Sub







Ref

https://www.spreadsheet1.com/how-to-copy-strings-to-clipboard-using-excel-vba.html
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849#p246687
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&start=20#p246887
https://docs.microsoft.com/en-us/office/vba/language/concepts/forms/what-is-the-difference-between-the-dataobject-and-the-clipboard
http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c
https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767
https://docs.microsoft.com/de-de/office/vba/access/Concepts/Windows-API/retrieve-information-from-the-clipboard
https://docs.microsoft.com/de-de/office/vba/access/Concepts/Windows-API/send-information-to-the-clipboard
https://social.msdn.microsoft.com/Forums/en-US/48e8c30c-24ee-458e-a873-a4e6e13f5926/dataobject-settext-and-putinclipboard-sequence-puts-invalid-data-hex-63-characters-in-clipboard?forum=isvvba
https://wellsr.com/vba/2015/tutorials/vba-copy-to-clipboard-paste-clear/
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246738#p246698
http://www.cpearson.com/excel/clipboard.aspx
http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849
** https://www.mrexcel.com/forum/excel-questions/828241-vba-autofilter-specialcells-xlcelltypevisible-copy-only-values-not-formulas.html#post4043472
https://www.mrexcel.com/forum/excel-questions/1012452-copy-clipboard.html#post4859707
https://www.spreadsheet1.com/how-to-copy-strings-to-clipboard-using-excel-vba.html
https://bytecomb.com/copy-and-paste-in-vba/
https://chandoo.org/forum/threads/clipboard-copy-vba-code-not-working-in-windows-10.37126/

[DocAElstein]

Coding in support of this post:
http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques?p=11018&viewfull=1#post11018





Sub MSFORMS_Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
'Dim DtaObj As New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy ' ' This seems to fill Excel, Windows and Office Clipboards http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246889#p246887
' Get some string version from some clipboard using a DataObject method
' Let Application.CutCopyMode = False ' generally speaking these two code lines will not clear the Windows Clipboards,
' Call ClearOffPainBouton ' but they do for the case of a range copy having put them in. So we can't do these here
DtaObj.GetFromClipboard ' ' This is filling a regisrre and possibly sometimes setting referrences that may prevent other things being done, or put them in a Queue, bit most likely to put a spanner in the works
Let Application.CutCopyMode = False
Call ClearOffPainBouton
' Range("A1:B2").Clear ' ' This will cause us to fail .. very strange .. this could suggest that we are still holding a range referrence at this stage
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear ' At this point it is fine to do this
Rem 3 examine string
Call WtchaGot(strIn:=strGet) ' ' Function to see string : https://pastebin.com/gtLaBrf5
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare) ' replace in the strGet , vbTab , with "|" pipes , I want all output so starting at first character , -1 means replace all occurances , exact match using computer exact digits
' Call ClearWindowsClipboard ' http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11020&viewfull=1#post11020 clearing the windows clipboard at this point also messes the simple reverse process from working. This makes no sense at all: Clearly clearing does not always clear things: It may do this in many occasions as one of its actions, but it can also do things which have something near to the opposite effect.

Rem 4 Replace the version previously got using another DataObject method
'4a) Simple reverse action
DtaObj.Clear ' Without this the following 2 line simple reverse action would not work
' DtaObj.SetText Text:=strGet: ' Let strGet = DtaObj.GetText() ' - This always gets the last "addition" ... https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767
' DtaObj.PutInClipboard
'4b) Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'Set LaterDtaObj = CreateObject("MSForms.DataObject") ' https://bytecomb.com/copy-and-paste-in-vba/
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub













' SHimpfGlified Coding
Sub Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy '
DtaObj.GetFromClipboard '
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear
Rem 3 examine string
' Call WtchaGot(strIn:=strGet) '
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare)
Rem Simple reverse action. Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub

[DocAElstein]

Global variables should go at top of code module

Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "HorizointalColumn" Indicies , "Virtical row" Indicies
Dim RngToSort As Range ' Test data range
Dim arrIndx() As Variant ' For modified array at end of each sort of a set of rows
Dim arrOrig() As Variant ' This arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range


A required function

Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
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
' https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887
' https://www.excelforum.com/tips-and-tutorials/1213798-all-sub-folder-and-file-list-from-vba-recursion-routine-explanation-and-method-comparison.html




Test routine to Call main recursion routine ( given in next post )

Sub TestieSimpleArraySort7()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
' Dim RngToSort As Range
Set RngToSort = WsS.Range("R23:W37")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
' Let arrIndx() = arrTS()
Let arrOrig() = arrTS() ' This Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range
' Call SimpleArraySort7(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
' Column Indicies
Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")")
Let Cms() = Evaluate("=Column(A:F)")
' Initial row indicies
Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")")
' test index
RngToSort.Offset(-1, 0).Resize(1, UBound(Cms())).Value = Cms()
RngToSort.Offset(0, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
RngToSort.Offset(RngToSort.Rows.Count, 0).Clear
Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrTS(), Rs(), Cms())
' Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrIndx(), Rs(), Cms())
RngToSort.Offset(RngToSort.Rows.Count, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To RngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs ' For 5 rows , for example we will have " 1 2 3 4 5 " , for 15 rows " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 "
Call SimpleArraySort7(1, arrTS(), strIndcs, " 1 Desc 3 Asc 5 Asc")
Rem 2 Output for easy of demo
' 2a
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
' 2b VBA Range.Sort Method equivalent
Dim TestRngSrt As Range: Set TestRngSrt = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
TestRngSrt.Clear
Let TestRngSrt.Value = RngToSort.Value
TestRngSrt.Sort Key1:=TestRngSrt.Columns("A:A"), order1:=xlDescending, Key2:=TestRngSrt.Columns("C:C"), order2:=xlAscending, Key3:=TestRngSrt.Columns("E:E"), order3:=xlAscending, MatchCase:=False
TestRngSrt.Interior.Color = vbGreen
End Sub

[DocAElstein]

Sub SimpleArraySort7(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have
If (2 * CopyNo) > UBound(Keys()) + 1 Then MsgBox Prompt:="You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
' making an array from the " 3 4 5 6 " string is just for convenience later of getting the upper and lower row numbers
Dim Rws() As String: Let Rws() = Split(Trim(strRws), " ", -1, vbBinaryCompare) ' We take the supplied sequential string 2 3 4 5 6 and make a 1 D array {1, 2, 3....} as it is a bit more conveniant to work with. Actually we only need the start and top numbers so we could do it with stinr manipulation instead
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = Rws(LBound(Rws())) To Rws(UBound(Rws()) - 1) ' For first row indicie to last but one row indicie
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rws(UBound(Rws())) ' from just above left hand through all the rest
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
'Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
'Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
'Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Debug.Print "Doing an arrIndx()"
Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms())
' Captains Blog, Start Treck
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Clear ' Area for array produced from previous method
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Value = arsRef()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Clear ' Area for array produced by Index method idea
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Value = arrIndx()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Clear
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs() ' Current indicies order to apply to original range
Debug.Print " Running Copy " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
' Rem 3 Determine any duplicates in sort column values , and re run the routine to sort them by another column
Let rOuter = Rws(LBound(Rws())) - 1 ' we look for duplicates in the current list, in the loop below we add 1 each time so _ it is necersarry to start 1 before, so that +1 the first time is the start row
Let strRws = "" ' ready for use in duplicate search
Do ' Loop down the last set of sorted rows ************************************************** **|
Let rOuter = rOuter + 1 ' next row number _ it was necersarry to start 1 before, so that +1 the first time is the start row
If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' when we did not have a next duplicate, we may have a few already grouped
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now Rec Call 1" ' This is done for every duplicated value section, except if we have duplicates at the last lines
Call SimpleArraySort7(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If
End If ' this is the end of the stuff in most situations...
' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last list, so now Rec Call 2 (Dups at list end case)" ' Rec Call 2 - only done for duplicates at end of list
Call SimpleArraySort7(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub

[DocAElstein]

Global variables required. ( Must go at top of code module )

Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies
Dim RngToSort As Range ' Test data range
Dim arrOrig() As Variant ' This arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range



A required function

Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
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
' https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887
' https://www.excelforum.com/tips-and-tutorials/1213798-all-sub-folder-and-file-list-from-vba-recursion-routine-explanation-and-method-comparison.html



Calling routine ( to call recursion routine in next post )

Sub TestieSimpleArraySort8()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
' Dim RngToSort As Range
Set RngToSort = WsS.Range("R23:W37")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Let arrIndx() = arrTS()
Let arrOrig() = arrTS() ' This Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range
' Call SimpleArraySort8(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
' Column Indicies
Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")")
Let Cms() = Evaluate("=Column(A:F)")
' Initial row indicies
Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")")
' test index
RngToSort.Offset(-1, 0).Resize(1, UBound(Cms())).Value = Cms()
RngToSort.Offset(0, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
RngToSort.Offset(RngToSort.Rows.Count, 0).ClearContents
Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrTS(), Rs(), Cms())
' Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrIndx(), Rs(), Cms())
RngToSort.Offset(RngToSort.Rows.Count, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To RngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs ' For 5 rows , for example we will have " 1 2 3 4 5 " , for 15 rows " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 "
Call SimpleArraySort8(1, arrTS(), strIndcs, " 1 Desc 3 Asc 5 Asc")
Rem 2 Output for easy of demo
' 2a
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
' 2b VBA Range.Sort Method equivalent
Dim TestRngSrt As Range: Set TestRngSrt = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
TestRngSrt.Clear
Let TestRngSrt.Value = RngToSort.Value
TestRngSrt.Sort Key1:=TestRngSrt.Columns("A:A"), order1:=xlDescending, Key2:=TestRngSrt.Columns("C:C"), order2:=xlAscending, Key3:=TestRngSrt.Columns("E:E"), order3:=xlAscending, MatchCase:=False
TestRngSrt.Interior.Color = vbGreen
End Sub


https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ- (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I)

[DocAElstein]

öfjlskjf


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg.9gvyL53lI1l9gxwd_9-V6z)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Coding for this excelfox Post:
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11066&viewfull=1#post11066

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

'
Sub Bubbles(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1
For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
'For rOuter = 1 To 5 ' For first run
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ================================================== ========================================

Rem 3 Preparation for possible recursion Call
' Catpains Blog
Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below
Let strRws = ""
'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1
For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative
If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces )
' Now its time to organise a recursion run
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated
Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If ' we did not have more than one indicie in strRws so usually that's it for this loop
End If
'+++*** this would be end of loop for most cases
' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list
Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Next rOuter ' ************************************************** ************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

This intermadiate routine is simply Sub Bubbles(), with the name changed to Sub BubblesIndexIdeaWay(), and the two recursion Calling code lines changed from
Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys)
to
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys)



'
Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1
For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
'For rOuter = 1 To 5 ' For first run
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ================================================== ========================================

Rem 3 Preparation for possible recursion Call
' Catpains Blog
Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below
Let strRws = ""
'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1
For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative
If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces )
' Now its time to organise a recursion run
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If ' we did not have more than one indicie in strRws so usually that's it for this loop
End If
'+++*** this would be end of loop for most cases ... but Oh Fuck
'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Next rOuter ' ************************************************** ************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub

[DocAElstein]

Original test data range , ( B11:E16 )

Row\Col
A
B
C
D
E

10


11
1
5
3a


12
9
9
9b


13
1
4
2c


14
8
8
8d


15
1
3
2e


16
7
7
7f
Worksheet: Sorting







Added initial row and column indicees

Row\Col
A
B
C
D
E

10
1
2
3
4


11
1
1
5
3a


12
2
9
9
9b


13
3
1
4
2c


14
4
8
8
8d


15
5
1
3
2e


16
6
7
7
7f
Worksheet: Sorting





https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Calling routine required for previous Post and following Post



Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation
' data range info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8

Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig()
Let arrTS() = RngToSort.Value
' Index idea variables
Let arrOrig() = arrTS()
Let arrIndx() = arrTS()
Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get
Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies
' Add initial indicies
Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
' Initial row indicies from full original range´of rows
Dim strRows As String, Cnt As Long: Let strRows = " "
For Cnt = 1 To 6
Let strRows = strRows & Rs(Cnt, 1) & " "
Next Cnt
' we should have now strRows = " 1 2 3 4 5 6 "
Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ")
' Demo output
Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count)
' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx()
Let RngDemoOutput = arrIndx()
Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
End Sub

[DocAElstein]

Recursion routine for this post:
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11078&viewfull=1#post11078



Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1
For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
'For rOuter = 1 To 5 ' For first run
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp
Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End=Rem 1================================================= ==============
Rem 2
Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms())
Rem 3 Preparation for possible recursion Call
' Catpains Blog
Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below
Let strRws = ""
'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1
For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative
If Trim(UCase(CStr(arrIndx(rOuter, Clm)))) = Trim(UCase(CStr(arrIndx(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces )
' Now its time to organise a recursion run
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated
Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If ' we did not have more than one indicie in strRws so usually that's it for this loop
End If
'+++*** this would be end of loop for most cases ... but Oh Fuck
'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arrIndx(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list
Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Next rOuter ' ************************************************** ************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub

[DocAElstein]

Some notes , tests in support of this
https://www.excelforum.com/excel-programming-vba-macros/1270189-copy-worksheet-1-from-the-first-file-in-a-folder-then-delete-the-file.html
These are just some notes and tests into what order the Dir( with wild cards ) thing does stuff.


Introduction
VBA Dir Function thing ( https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function )
In the simplest form, ….._
_____ Dir(Fullpath&FileName, __ )
_............

Dim IsFileName As String
IsFileName = Dir("C:\MyFolder\myFileName.xls", __ )
this basically gives you the file name back if it exists, based on you giving it the full path and File name string, Fullpath&FileName.
In the above example, if you had the file "myFileName.xls" in the foilder, "MyFolder", then the text "myFileName.xls" would be Placed in variable , IsFileName
If that file does not exist, then it gives you back nothing, or rather an empty string of sorts “” ( I believe Dir is a throw back to older early computer days, when you typed something like Dir C:_____, and the result was that you got to go to that place which Dir C:_____ represented )
It seem that in VBA the Dir is mostly used to loop through all files in a single folder*. ( *It does not suit too well for use in coding looking at all files in folders and sub folders ). The suitability of the Dir function for this is based on a couple of things.
_(i) In Microsoft Windows, Dir supports the use of multiple character (*) and single character (?) wildcards to specify multiple files. ......
You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… )
__Dir _____ without arguments
IsFileName = Dir
_(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the criteria given by the wild carded full path and file name string you gave in the first use with arguments, or it returns "" if there are no further files meeting the criteria given by the wild carded full path and file name string you gave in the first use with arguments

What this post is about:
My interest was sparked by the reference thread ( https://www.excelforum.com/excel-programming-vba-macros/1270189-copy-worksheet-1-from-the-first-file-in-a-folder-then-delete-the-file.html )
I am interested in finding out which of the files Dir or Dir(Fullpath&FileName, __ )will choose if there are more than 1 file meeting the criteria of a string , Fullpath&FileName , containing wild cards



Experiments so far
I made a test folder , named "Folder"
Folder.JPG : https://imgur.com/l9OwlQi
2213

I created my files in this order
_1 “wbCodes.xlsm” --- the main file with all the codes in it. This is in the same Folder as the folder which I named "Folder" ( The main Folder is called “Kill Stuff” : Kill Stuff Folder.JPG : https://imgur.com/hN26AoW )
After making the main File, I created the folder, "Folder" , and created the following files in it. I created the following three files in the following order,
_2 “SecondFirstAfterwb.xlsx” --- made first after making “wbCodes.xlsm”
_3 “ThirdSecondAfterwb.xlsx” --- made second after making “wbCodes.xlsm”
_4 “AForthThirdAfterwb.xlsx” --- made third after making “wbCodes.xlsm”

I modified the codes from Alf and sintek from the referenced Thread, thus, ( I am mainly interested in the first part of the routines, as this deals with what the Dir chooses )


Sub zed369() ' sintek
Dim Path As String, File As String, Cnt As Long
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
' sintek's Dir Stuff
'Application.ScreenUpdating = False
Set wb1 = ThisWorkbook: Set ws1 = wb1.Sheets("Sheet1")
Path = ThisWorkbook.Path & "\Folder\": File = Dir(Path & "*.xl*") ' For this example, specific file is in a folder called Folder...same path as macro file...
Debug.Print "First got by Dir is " & File
Debug.Print
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
File = Dir: Debug.Print " use " & Cnt & " in loop of Dir gives " & File
Next Cnt
Debug.Print
Debug.Print


' sintek's way to do stuff
'Stop ' __________________________________________________ ___________________________
'Set wb2 = Workbooks.Open(Path & File): Set ws2 = wb2.Sheets("Tabelle1")
'With ws2
' .UsedRange.Copy ws1.Range("A1")
'End With
'wb2.Close
'Kill Path & File
'Application.ScreenUpdating = True
End Sub
'
Sub CopyAndKill() ' Alf
Dim aString As String, Cnt As Long, aStringToOpen As String
' Alf's Dir stuff
'aString = Dir("N:\a_test\")
aString = Dir("F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder\")
Debug.Print "First got by Dir is " & aString
aStringToOpen = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder\" & Dir("F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder\")
Debug.Print "First file will be opened using this string " & vbCrLf & aStringToOpen
Debug.Print
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
aString = Dir: Debug.Print " use " & Cnt & " in loop of Dir gives " & aString
Next Cnt
Debug.Print
Debug.Print


'Stop ' __________________________________________________ ________________
' Alf's way to do the stuff
'Workbooks.Open ("N:\a_test\" & Dir("N:\a_test\"))
'Sheets("Sheet1").Activate
'ActiveSheet.UsedRange.Copy
'ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial Paste:=xlAll
'Application.CutCopyMode = False
'Windows(aString).Close
'Kill ("N:\a_test\" & Dir("N:\a_test\"))
End Sub

I get this sort of output ( in the immediate window )

First got by Dir is AForthThirdAfterwb.xlsx

use 1 in loop of Dir gives SecondFirstAfterwb.xlsx
use 2 in loop of Dir gives ThirdSecondAfterwb.xlsx


First got by Dir is AForthThirdAfterwb.xlsx
First file will be opened using this string
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder\AForthThirdAfterwb.xlsx

use 1 in loop of Dir gives SecondFirstAfterwb.xlsx
use 2 in loop of Dir gives ThirdSecondAfterwb.xlsx
Initially it appears that I get alphabetic order.
But possibly there could be more to it than that.
I will look again at this in a few days , possibly on some other computers and systems, and experiment with various settings , etc….



In the next posts I will use this simplified routine which is only interested in looking at the order in which Dir chooses files.
Rem 1 gives a few ways to get the string up to and including the Folder in which files are to be searched for, ( in the form below , ‘1b ) , is used to get the folder named “Folder” in the same folder as the workbook in which the routine is placed )
Rem 2 : As before, an initial use of Dir(C:\somewhers\kjhfkhs.*sdfjkah,___) is made to set the search criteria, followed by the un argumented Dir in a loop which then looks for the next files


Sub DirOrder()
Dim strWB As String
Rem 1 get the full string, strWB, for a Folder to use in the Dir(Fullpath&FileName, __ ) ( strWB=Fullpath&FileName - FileName )
'1a) use the asking pop up thing, File dialogue folder picker
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Folder Select"
' .AllowMultiSelect = False
' If .Show <> -1 Then
' Exit Sub
' Else
' End If
' Let strWB = .SelectedItems(1) ' & "\"
' End With
'
'1b) Using a test Folder, named Folder in the same Folder as the workbook in which this code is
Let strWB = ThisWorkbook.Path & "\Folder"
'1c) Hard code instead
'Let strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder"
Debug.Print "Folder used is" & vbCrLf & strWB & vbCrLf & "" & Right(strWB, (Len(strWB) - InStrRev(strWB, "\", -1, vbTextCompare)))
Debug.Print
Let strWB = strWB & "\"
Rem 2 add last file bit for use in the Dir(Fullpath&FileName, __ ) , but include wild cards... http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11089&viewfull=1#post11089 : _(i) You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… ) _(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the string you gave in the first use with arguments
'2a) Excel files
Let strWB = strWB & "*.xls*"
Dim file As String: Let file = Dir(strWB)
Debug.Print "First got by Dir(" & strWB & ")" & vbCrLf & "is " & file
Debug.Print
Dim Cnt As Long
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
file = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives " & file
Next Cnt
Debug.Print
Debug.Print
End Sub

This would be comparible output ( in the Immedite Window ( http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 ) ) to the test files anf folder used so far


Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder
Folder

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx
Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx

And here is what it looks like in the explorer window:
ExpOrder1.JPG : https://imgur.com/OfQfHeH
2224

[DocAElstein]

Here is where we left off in the last post

Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder
Folder

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx
Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx
here is what it looks like in the explorer window:
ExpOrder1.JPG : https://imgur.com/OfQfHeH

I can move the order pysically in the explorer window, by selecting and dragging the file position virtically, ( and I hit the refresh thing , just in case that should influence anything )
ExpOrder2.JPG : https://imgur.com/AlV1MdB
The routine, Sub DirOrder() , then seems to give the same results

Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder
Folder

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx
Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx

I can do this:
ExpOrder3a.JPG : https://imgur.com/RBSa9Ou
ExpOrder3a.JPG : https://imgur.com/2OVsguZ
Once again I get the same alphabetical ordering in the Dir found order output
i can play around with this:
ExpOrder4.JPG : https://imgur.com/6FbYQgp
or this
Stack by change date.jpg : https://imgur.com/YIrTxpp , https://imgur.com/ht887FU , https://imgur.com/lHMcUjA
2226
Once again I get the same alphabetical ordering in the Dir found order output

I made this d_xlsm_file.xlsm , and this ,c_xls_file.xls , and pit it in the foilder, Folder
A xlsm and xls.JPG : https://imgur.com/w9gyRxj
2225
here is part of my Immediate window output

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives c_xls_file.xls
Use 2 in loop of unargumented Dir gives d_xlsm_file.xlsm
I need to increase my loop count, Cnt , to 4 to getting total all 5 files. But doing this is likely to get a bit tedious as I comtinue experiments with a different number of files in various folders. So I will change my coding, at the loop section, to a more typical type of loop used iin such a Dir __ file finding code: Usually something like this is done, so that the loop keeps going as long as Dir __ finds files


‘ First use of Dir with full path and file name argument
‘ strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder\*.xls*" ‘ Wild card to get all Excel Files
‘ File = Dir(strWB)
‘
‘
‘ Loop for all files meeting search string criteria, ( all Excel files in this example )
Do ' '_- I want to keep going in a Loop while I still get a file name returned by Dir
Dim Cnt As Long: Let Cnt = Cnt + 1
File = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives """ & File & """"
Loop While File <> "" '_- I want to keep going in a Loop while I still get a file name returned by Dir
Here is the full coding, http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11108&viewfull=1#post11108 , which gives for the last example:

F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder
Folder

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives "c_xls_file.xls"
Use 2 in loop of unargumented Dir gives "d_xlsm_file.xlsm"
Use 3 in loop of unargumented Dir gives "SecondFirstAfterwb.xlsx"
Use 4 in loop of unargumented Dir gives "ThirdSecondAfterwb.xlsx"
Use 5 in loop of unargumented Dir gives ""

I can change the serach criteria from strWB & "*.xls*" to strWB & "*" and it has no effect
i added a .jpg pic, ( Add a jpg.JPG : https://imgur.com/XkXskiL ) , and the listing had it in the aplhabetical order :

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\Kill Stuff\Folder\*)
is AForthThirdAfterwb.xlsx

Use 1 in loop of unargumented Dir gives "c_xls_file.xls"
Use 2 in loop of unargumented Dir gives "d_xlsm_file.xlsm"
Use 3 in loop of unargumented Dir gives "SecondFirstAfterwb.xlsx"
Use 4 in loop of unargumented Dir gives "Stack by change date .JPG"
Use 5 in loop of unargumented Dir gives "ThirdSecondAfterwb.xlsx"
Use 6 in loop of unargumented Dir gives ""
I use the last routine in the form to allow user selection of the folder to search for files
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11108&viewfull=1#post11108. I looked at some arbritrary folders, - once again alphabetical order seems to come out:

Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery
wbSheetMakerClsdWbADOMsQueery

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\*)
is 83DB8900

Use 1 in loop of unargumented Dir gives "aaa.xlsm"
Use 2 in loop of unargumented Dir gives "Amar321.xls.xlsx"
Use 3 in loop of unargumented Dir gives "ApparantlyApparantIs_Change.JPG"
Use 4 in loop of unargumented Dir gives "Aufzeichnen.JPG"
Use 5 in loop of unargumented Dir gives "Book1.xls"
Use 6 in loop of unargumented Dir gives "Book1.xlsm.zip"
Use 7 in loop of unargumented Dir gives "CA930CD8.tmp"
Use 8 in loop of unargumented Dir gives "ClosedWorkbook.xlsm"
Use 9 in loop of unargumented Dir gives "CopyASheet.JPG"
Use 10 in loop of unargumented Dir gives "CresssieFiles.JPG"
Use 11 in loop of unargumented Dir gives "DB2IssJfürELProAbDec2014.xlsm"
Use 12 in loop of unargumented Dir gives "EFFldr.xlsm"
Use 13 in loop of unargumented Dir gives "EFldr1_1 Download.JPG"
Use 14 in loop of unargumented Dir gives "Eileens Fldr.zip"
Use 15 in loop of unargumented Dir gives "EileensFldr Contents Copy.JPG"
Use 16 in loop of unargumented Dir gives "EileensFldr Contents Paste.JPG"
Use 17 in loop of unargumented Dir gives "EileensFldr Make Empty Folder.JPG"
Use 18 in loop of unargumented Dir gives "EileensFldr zip Download.JPG"
Use 19 in loop of unargumented Dir gives "EileensFldr.zip"
Use 20 in loop of unargumented Dir gives "EileensFolderExplainedOutput.JPG"
Use 21 in loop of unargumented Dir gives "Example Folder and Macro File in same Folder.JPG"
Use 22 in loop of unargumented Dir gives "FBandData.xlsm"
Use 23 in loop of unargumented Dir gives "FBandDataNorie.xlsm"
Use 24 in loop of unargumented Dir gives "FBandDataNorie.xlsx"
Use 25 in loop of unargumented Dir gives "FormulaBarClosedWB.JPG"
Use 26 in loop of unargumented Dir gives "GetData_ClosedBook+LINKS.xlsx"
Use 27 in loop of unargumented Dir gives "GetData_ClosedBook.xls"
Use 28 in loop of unargumented Dir gives "HimanshuktwCode.JPG"
Use 29 in loop of unargumented Dir gives "KissMyClosedWB.JPG"
Use 30 in loop of unargumented Dir gives "Mappe2.xlsm"
Use 31 in loop of unargumented Dir gives "MazanDikCollectionWonk.xlsm"
Use 32 in loop of unargumented Dir gives "mellowtangSummarySheets.xlsm"
Use 33 in loop of unargumented Dir gives "MsQueerOptions.JPG"
Use 34 in loop of unargumented Dir gives "myFileToClose.xlsm"
Use 35 in loop of unargumented Dir gives "MyNewWorkbook.xlsx"
Use 36 in loop of unargumented Dir gives "MySameFolder.JPG"
Use 37 in loop of unargumented Dir gives "NeuProAktuelleMakros.xlsm"
Use 38 in loop of unargumented Dir gives "NormalThisWorkbookCodeModule.JPG"
Use 39 in loop of unargumented Dir gives "NutritionalValues2016.xlsx"
Use 40 in loop of unargumented Dir gives "OnlyGets8810RowsInAQuerrListObjectTableThingyAnywa ys.JPG"
Use 41 in loop of unargumented Dir gives "Plop.xlsm"
Use 42 in loop of unargumented Dir gives "poo.xlsm"
Use 43 in loop of unargumented Dir gives "RudyMSRAllSubFldrsFndRep.xlsm"
Use 44 in loop of unargumented Dir gives "Sample.zip"
Use 45 in loop of unargumented Dir gives "SchemaIniErrorPipe.JPG"
Use 46 in loop of unargumented Dir gives "SrangeThisWorkbookCodeModule.JPG"
Use 47 in loop of unargumented Dir gives "StopClosing.xlsm"
Use 48 in loop of unargumented Dir gives "Summary sheet.xlsm"
Use 49 in loop of unargumented Dir gives "template test.xlsm"
Use 50 in loop of unargumented Dir gives "Top100MsQuery.JPG"
Use 51 in loop of unargumented Dir gives "ViskasVerticalsMaster dataMjoza.xlsm"
Use 52 in loop of unargumented Dir gives "wb2.csv"
Use 53 in loop of unargumented Dir gives "wb2.xlsm"
Use 54 in loop of unargumented Dir gives "wb2.xlsx"
Use 55 in loop of unargumented Dir gives "WBAccessTimeTestData.xlsx"
Use 56 in loop of unargumented Dir gives "WBAccestTimeTest.xlsm"
Use 57 in loop of unargumented Dir gives "wbCodes.xlsb"
Use 58 in loop of unargumented Dir gives "wbCodes.xlsm"
Use 59 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xls"
Use 60 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xlsm"
Use 61 in loop of unargumented Dir gives "Wb_with_5Sheets_4Worksheets.xlsm"
Use 62 in loop of unargumented Dir gives "WillyWonks.JPG"
Use 63 in loop of unargumented Dir gives "workbook2.xlsm"
Use 64 in loop of unargumented Dir gives "WorkbookOpenMsgBox.JPG"
Use 65 in loop of unargumented Dir gives "WorksheetNames.JPG"
Use 66 in loop of unargumented Dir gives "Worksheet_Change.JPG"
Use 67 in loop of unargumented Dir gives ""
Note that a file named as a number comes first in the list, as is consitant with Excel regarding text as "larger" than a number in sorting things http://www.eileenslounge.com/viewtopic.php?f=27&t=32154#p249178

Up until now, all tests were done on an old Lap top using Vista operating system. I rechecked on a newer machine uisng Windows 7. I get the same results












"wbCodes.xlsm" : https://app.box.com/s/gfuintgifu1hgw5nap3jriz2x8mp911x ( Sub DirOrder() is here )
folder, "Folder" : https://app.box.com/s/vmmzeboetkt07ocggbx6p8lkurmp5wca
"wbCodes.xls" : https://app.box.com/s/gmdne53vehhuc6lvz3vfgyxqmwy07xlz ( Sub DirOrder() is here )



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

There is a second argument to Dir. It is not used much. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function#settings
One option will make it return folder names as well. For our example we can change Dir(strWB) to any if these: Dir(strWB, vbDirectory) ; Dir(PathName:=strWB, Attributes:=vbDirectory) ; Dir(PathName:=strWB, Attributes:=16) ; Dir(strWB, 16)
Running the routine with the previous example, seems to slip the folder names in the appropriate place to once again have everything in alphabetical order

Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery
wbSheetMakerClsdWbADOMsQueery

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMaker ClsdWbADOMsQueery\*)
is .

Use 1 in loop of unargumented Dir gives ".."
Use 2 in loop of unargumented Dir gives "83DB8900"
Use 3 in loop of unargumented Dir gives "aaa.xlsm"
Use 4 in loop of unargumented Dir gives "ACDC"
Use 5 in loop of unargumented Dir gives "Amar321.xls.xlsx"
Use 6 in loop of unargumented Dir gives "ApparantlyApparantIs_Change.JPG"
Use 7 in loop of unargumented Dir gives "Aufzeichnen.JPG"
Use 8 in loop of unargumented Dir gives "Bad Files"
Use 9 in loop of unargumented Dir gives "Book1.xls"
Use 10 in loop of unargumented Dir gives "Book1.xlsm.zip"
Use 11 in loop of unargumented Dir gives "CA930CD8.tmp"
Use 12 in loop of unargumented Dir gives "ClosedWorkbook.xlsm"
Use 13 in loop of unargumented Dir gives "ClsdWbs"
Use 14 in loop of unargumented Dir gives "CopyASheet.JPG"
Use 15 in loop of unargumented Dir gives "CressieFolder"
Use 16 in loop of unargumented Dir gives "CresssieFiles.JPG"
Use 17 in loop of unargumented Dir gives "DB2IssJfürELProAbDec2014.xlsm"
Use 18 in loop of unargumented Dir gives "EFFldr.xlsm"
Use 19 in loop of unargumented Dir gives "EFldr1_1"
Use 20 in loop of unargumented Dir gives "EFldr1_1 Download.JPG"
Use 21 in loop of unargumented Dir gives "Eileens Fldr.zip"
Use 22 in loop of unargumented Dir gives "EileensFldr"
Use 23 in loop of unargumented Dir gives "EileensFldr Contents Copy.JPG"
Use 24 in loop of unargumented Dir gives "EileensFldr Contents Paste.JPG"
Use 25 in loop of unargumented Dir gives "EileensFldr Make Empty Folder.JPG"
Use 26 in loop of unargumented Dir gives "EileensFldr zip Download.JPG"
Use 27 in loop of unargumented Dir gives "EileensFldr.zip"
Use 28 in loop of unargumented Dir gives "EileensFolderExplainedOutput.JPG"
Use 29 in loop of unargumented Dir gives "Example Folder and Macro File in same Folder.JPG"
Use 30 in loop of unargumented Dir gives "FBandData.xlsm"
Use 31 in loop of unargumented Dir gives "FBandDataNorie.xlsm"
Use 32 in loop of unargumented Dir gives "FBandDataNorie.xlsx"
Use 33 in loop of unargumented Dir gives "FormulaBarClosedWB.JPG"
Use 34 in loop of unargumented Dir gives "GetData_ClosedBook+LINKS.xlsx"
Use 35 in loop of unargumented Dir gives "GetData_ClosedBook.xls"
Use 36 in loop of unargumented Dir gives "HimanshuktwCode.JPG"
Use 37 in loop of unargumented Dir gives "Kill Stuff"
Use 38 in loop of unargumented Dir gives "KissMyClosedWB.JPG"
Use 39 in loop of unargumented Dir gives "MacroRecording"
Use 40 in loop of unargumented Dir gives "Mappe2.xlsm"
Use 41 in loop of unargumented Dir gives "MazanDikCollectionWonk.xlsm"
Use 42 in loop of unargumented Dir gives "mellowtangSummarySheets.xlsm"
Use 43 in loop of unargumented Dir gives "MsQueerOptions.JPG"
Use 44 in loop of unargumented Dir gives "MsQueeryADO"
Use 45 in loop of unargumented Dir gives "myFileToClose.xlsm"
Use 46 in loop of unargumented Dir gives "MyNewWorkbook.xlsx"
Use 47 in loop of unargumented Dir gives "MySameFolder.JPG"
Use 48 in loop of unargumented Dir gives "Neuer Ordner"
Use 49 in loop of unargumented Dir gives "NeuProAktuelleMakros.xlsm"
Use 50 in loop of unargumented Dir gives "NormalThisWorkbookCodeModule.JPG"
Use 51 in loop of unargumented Dir gives "NutritionalValues2016.xlsx"
Use 52 in loop of unargumented Dir gives "OnlyGets8810RowsInAQuerrListObjectTableThingyAnywa ys.JPG"
Use 53 in loop of unargumented Dir gives "Plop.xlsm"
Use 54 in loop of unargumented Dir gives "poo.xlsm"
Use 55 in loop of unargumented Dir gives "RudyMSRAllSubFldrsFndRep.xlsm"
Use 56 in loop of unargumented Dir gives "Sample.zip"
Use 57 in loop of unargumented Dir gives "SchemaIniErrorPipe.JPG"
Use 58 in loop of unargumented Dir gives "SrangeThisWorkbookCodeModule.JPG"
Use 59 in loop of unargumented Dir gives "StopClosing.xlsm"
Use 60 in loop of unargumented Dir gives "Summary sheet.xlsm"
Use 61 in loop of unargumented Dir gives "template test.xlsm"
Use 62 in loop of unargumented Dir gives "Top100MsQuery.JPG"
Use 63 in loop of unargumented Dir gives "ViskasVerticalsMaster dataMjoza.xlsm"
Use 64 in loop of unargumented Dir gives "wb2.csv"
Use 65 in loop of unargumented Dir gives "wb2.xlsm"
Use 66 in loop of unargumented Dir gives "wb2.xlsx"
Use 67 in loop of unargumented Dir gives "WBAccessTimeTestData.xlsx"
Use 68 in loop of unargumented Dir gives "WBAccestTimeTest.xlsm"
Use 69 in loop of unargumented Dir gives "wbCodes.xls"
Use 70 in loop of unargumented Dir gives "wbCodes.xlsb"
Use 71 in loop of unargumented Dir gives "wbCodes.xlsm"
Use 72 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xls"
Use 73 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xlsm"
Use 74 in loop of unargumented Dir gives "Wb_with_5Sheets_4Worksheets.xlsm"
Use 75 in loop of unargumented Dir gives "WillyWonks.JPG"
Use 76 in loop of unargumented Dir gives "WonkBook"
Use 77 in loop of unargumented Dir gives "workbook2.xlsm"
Use 78 in loop of unargumented Dir gives "WorkbookOpenMsgBox.JPG"
Use 79 in loop of unargumented Dir gives "WorksheetNames.JPG"
Use 80 in loop of unargumented Dir gives "Worksheet_Change.JPG"
Use 81 in loop of unargumented Dir gives "XYT"
Use 82 in loop of unargumented Dir gives ""
Here is the folder used for the last two tests: wbFolder.JPG : https://imgur.com/MMydq7n



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In support of answer to this excelfox Thread:
http://www.excelfox.com/forum/showthread.php/2322-How-to-populate-the-column-3-under-this-condition?p=11090&viewfull=1#post11090



Option Explicit
Sub DefaultItem()
Rem 1 data range info
Dim rngIn As Range, Lr As Long, ClmCnt As Long
Let ClmCnt = 3 ' : Let ClmCnt = Worksheets("Sheet2").Range("A1").CurrentRegion.Columns.Count
Let Lr = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
Set rngIn = Worksheets("Sheet2").Range("A1:C" & Lr & "")
Rem 2 Data to array
Dim arrDtaIn() As Variant ' I need Variant type as the .Value in the next line returns a field of Variant type elements
Let arrDtaIn() = rngIn.Value
Rem 3 Determine default values
' 3a) Number of groups
Dim arrGp() As Variant: Let arrGp() = Application.Index(rngIn, 0, 1).Value ' http://www.excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%E2%80%93-Application-Index Highlight arrGp and Hit F9.JPG : https://imgur.com/PZF0oXE
Dim strGps As String: Let strGps = " " ' For a string like " 1 2 3 "
Dim cnt As Long
For cnt = 2 To Lr ' looking at all rows from the second in our input data
If InStr(1, strGps, " " & arrGp(cnt, 1) & " ") = 0 Then ' This looks for the positiopn along ( starting from character 1 , in strGps , of each row element arrGp(cnt, 1) ) if it is not found then Instr retourns 0 as a n indication that it was not there
Let strGps = strGps & arrGp(cnt, 1) & " " ' Because it is not there, we now put it in
Else
End If
Next cnt
' At this point we should have like strGps = " 1 2 3 "
' 3b) Array of unique groups
Let strGps = Trim(strGps) ' This takes off the first and last trailing spaces
Dim arrGps() As String ' The string split function below returns a fiels of String elements : Highlight arrGps Hit F9.JPG : https://imgur.com/LT9dgHk
Let arrGps() = Split(strGps, " ", -1, vbBinaryCompare) ' this splits the ( strgps , using " " as denominator , and returns all elemants in an array, using exact binary computer match on the " " )
' 3c) Array for output
Dim arrOut() As String ' A dynamic array is needed as I can only use variables in the ReDim method - I cannot use varable in the declaration (Dim) statement
ReDim arrOut(1 To UBound(arrGps()) + 2, 1 To 2) ' I want +1 rows for the header I also need +1 because split retouns a 1 dimensional array stating at indicie 0 - so the Ubound of arrGps() will give a numbe 1 less than I might expect - in our example we have 3 elements with indicies of 0 1 2, ( and values in our example of 1 2 3 - for example arrGps(0)=1 ) so the Ubound returns 2 - but we want 3 elements
' 3d) fill my arrOut()
Dim Stear As Variant ' I want to use a For ´Each loop below VBA must have an object varaible or a variable of variant type to hold each item in a collection of something. Our arrGps() can be considered a collection of numbers 1 2 3
Dim ArrOutRw As Long: Let ArrOutRw = 1 ' Our row number in the outout array : I use 1 initially, for the header
Let arrOut(ArrOutRw, 1) = arrDtaIn(1, 1): Let arrOut(ArrOutRw, 2) = "Deafault item"
For Each Stear In arrGps() ' This outer loop goes throug each unique group number =============== - For each number in { 1, 2, 3 }
For cnt = 2 To Lr ' An Inner loop to go through all data rows ' -----------------------------
If CStr(arrDtaIn(cnt, 1)) = CStr(Stear) Then ' This will catch the first use of our group number, Stear is our group number taken from the array 1 2 3
Let ArrOutRw = ArrOutRw + 1 ' Our next row to fill in arrOut()
Let arrOut(ArrOutRw, 1) = Stear ' First column in our output array
Let arrOut(ArrOutRw, 2) = arrDtaIn(cnt, 2) ' Second column in our output array will be given the first item in column B of our data for this group number, Stear
Exit For ' I only want to get the first item for a group number
Else
End If
Next cnt ' ----------------------------------------------------------------------------------
Next Stear ' ================================================== ==================================
' at this point we have an array for output of default : Select ArrOut then Hit F9.JPG : https://imgur.com/CNMeYV9
Rem 4 Demo Output
Let rngIn.Offset(0, ClmCnt).Resize(UBound(arrOut(), 1), 2).Value = arrOut() ' In the range which offset to the right of the input, of the dimension size of the output array, I paste my values out

End Sub

[DocAElstein]

Coding in suport of these excelfox Threads and posts:
http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11089&viewfull=1#post11089
https://www.excelforum.com/excel-programming-vba-macros/1270189-copy-worksheet-1-from-the-first-file-in-a-folder-then-delete-the-file.html


Sub DirOrder() ' http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11092&viewfull=1#post11092
Dim strWB As String
Rem 1 get the full string, strWB, for a Folder to use in the Dir(Fullpath&FileName, __ ) ( strWB=Fullpath&FileName - FileName )
'1a) use the asking pop up thing, File dialogue folder picker
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Folder Select"
' .AllowMultiSelect = False
' If .Show <> -1 Then
' Exit Sub
' Else
' End If
' Let strWB = .SelectedItems(1) ' & "\"
' End With
'
'1b) Using a test Folder, named Folder in the same Folder as the workbook in which this code is
Let strWB = ThisWorkbook.Path & "\Folder"
'1c) Hard code instead
'Let strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder"
Debug.Print "Folder used is" & vbCrLf & strWB & vbCrLf & "" & Right(strWB, (Len(strWB) - InStrRev(strWB, "\", -1, vbTextCompare)))
Debug.Print
Let strWB = strWB & "\"
Rem 2 add last file bit for use in the Dir(Fullpath&FileName, __ ) , but include wild cards... http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11089&viewfull=1#post11089 : _(i) You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… ) _(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the string you gave in the first use with arguments
'2a) Excel files
Let strWB = strWB & "*.xls*"
Dim File As String: Let File = Dir(strWB)
Debug.Print "First got by Dir(" & strWB & ")" & vbCrLf & "is " & File
Debug.Print
Do ' '_- I want to keep going in a Loop while I still get a file name returned by Dir
Dim Cnt As Long: Let Cnt = Cnt + 1
Let File = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives """ & File & """"
Loop While File <> "" '_- I want to keep going in a Loop while I still get a file name returned by Dir
Debug.Print
Debug.Print
End Sub


Here last routine in form to allow user selection of folder to search for files

Sub DirOrder() ' http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11093&viewfull=1#post11093
Dim strWB As String
Rem 1 get the full string, strWB, for a Folder to use in the Dir(Fullpath&FileName, __ ) ( strWB=Fullpath&FileName - FileName )
'1a) use the asking pop up thing, File dialogue folder picker
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Folder Select"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
Else
End If
Let strWB = .SelectedItems(1) ' & "\"
End With

'1b) Using a test Folder, named Folder in the same Folder as the workbook in which this code is
'Let strWB = ThisWorkbook.Path & "\Folder"
'1c) Hard code instead
'Let strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsd WbADOMsQueery\Kill Stuff\Folder"
Debug.Print "Folder used is" & vbCrLf & strWB & vbCrLf & "" & Right(strWB, (Len(strWB) - InStrRev(strWB, "\", -1, vbTextCompare)))
Debug.Print
Let strWB = strWB & "\"
Rem 2 add last file bit for use in the Dir(Fullpath&FileName, __ ) , but include wild cards... http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11089&viewfull=1#post11089 : _(i) You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… ) _(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the string you gave in the first use with arguments
'2a) Excel files
Let strWB = strWB & "*"
Dim File As String: Let File = Dir(strWB)
Debug.Print "First got by Dir(" & strWB & ")" & vbCrLf & "is " & File
Debug.Print
Do ' '_- I want to keep going in a Loop while I still get a file name returned by Dir
Dim Cnt As Long: Let Cnt = Cnt + 1
Let File = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives """ & File & """"
Loop While File <> "" '_- I want to keep going in a Loop while I still get a file name returned by Dir
Debug.Print
Debug.Print
End Sub

[DocAElstein]

Initial coding for solution to this Thread
http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11124&viewfull=1#post11124


File : "Data Sheet.xls" : https://app.box.com/s/wvusyk3ish5z3mxdwvw3sw9n683m58rq


Option Explicit '
Sub HaiderAdSlots1() ' http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11124&viewfull=1#post11124
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim Lr1 As Long, Lr2 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "").Row: Let Lr2 = Ws1.Range("A" & Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row & "").Row
'1b) data arrays, original data
Dim arrInSht2() As Variant, arrOutSht1() As Variant
Let arrInSht2() = Ws2.Range("A1:G" & Lr2 & "").Value2: Let arrOutSht1() = Ws1.Range("A1:C" & Lr1 & "").Value2
'1b)(ii) extra "column" for outout
ReDim Preserve arrOutSht1(1 To Lr1, 1 To 4) ' we may add a last dimension, but must keep the others the same as they were
Rem 2 arrays to identify rows ... " Channel Name & Date & Time "
Dim arrInId() As String
ReDim arrInId(1 To Lr2)
Dim cnt As Long
For cnt = 2 To Lr2
Let arrInId(cnt) = arrInSht2(cnt, 1) & " | " & arrInSht2(cnt, 2) & " | " & arrInSht2(cnt, 3)
Next cnt
Dim arrOutId() As String
ReDim arrOutId(1 To Lr1)
For cnt = 2 To Lr1
Let arrOutId(cnt) = arrOutSht1(cnt, 2) & " | " & arrOutSht1(cnt, 1) & " | " & arrOutSht1(cnt, 3)
Next cnt
Rem 3 match up rows in data sheets
For cnt = 2 To Lr1
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrOutId(cnt), arrInId(), 1) ' return the position along of a match ( looking for arrOutId(cnt) , in arrInId() , 1 indicates approximate match )
If Not IsError(MtchRes) Then
'3b)
Let arrOutSht1(cnt, 4) = arrInSht2(MtchRes, 3)
Else
End If
Next cnt
Rem 4
Let ThisWorkbook.Worksheets("OutputTest").Range("A1").Resize(UBound(arrOutSht1(), 1), 4).Value = arrOutSht1()

End Sub

[DocAElstein]

In support of answer to this Thread
http://www.excelfox.com/forum/showthread.php/2331-Use-VBA-to-automate-entry-of-schedule-scores

_____ Workbook: NFL 2019 Schedule.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S

1
Week # 1


09.08.19



2V TeamGBLARWASBUFATLBALKCTENINDCINSFNYGDETPITHOUDEN
TOTAL


3V Score
















0


4H Score



















5H TeamCHICARPHINYJMINMIAJAXCLELACSEATBDALARINENOOAK


6BYES


7


8
Week # 2


09.15.19



9V TeamTBARIDALINDSEABUFSFLACMINJAXNEKCNOCHIPHICLE


10V Score
















0


11H Score



















12H TeamCARBALWASTENPITNYGCINDETGBHOUMIAOAKLARDENATLNY J


13BYES


14
Worksheet: 2019


_____ Workbook: NFL 2019 Schedule.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S

1
Week # 1


09.08.19



2V TeamGBLARWASBUFATLBALKCTENINDCINSFNYGDETPITHOUDEN
TOTAL


3V Score
















=SUM(B3:Q4)


4H Score



















5H TeamCHICARPHINYJMINMIAJAXCLELACSEATBDALARINENOOAK


6BYES


7


8
Week # 2


09.15.19



9V TeamTBARIDALINDSEABUFSFLACMINJAXNEKCNOCHIPHICLE


10V Score
















=SUM(B10:Q11)


11H Score



















12H TeamCARBALWASTENPITNYGCINDETGBHOUMIAOAKLARDENATLNY J


13BYES


14
Worksheet: 2019

[DocAElstein]

In support of this thread
http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11134&viewfull=1#post11134

Sheet2v3.JPG : 2245

_____ Workbook: Data Sheet v3.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
1ChannelDateAdStartMidBreakBreak_StartBreak_EndHou r

2A NEWS15.11.201720:19:12Mid Break-120:19:0820:24:0720

3A NEWS15.11.201720:19:32Mid Break-120:19:0820:24:0720

4A NEWS15.11.201720:19:49Mid Break-120:19:0820:24:0720

5A NEWS15.11.201720:20:01Mid Break-120:19:0820:24:0720

6A NEWS15.11.201720:20:47Mid Break-120:19:0820:24:0720

7A NEWS15.11.201720:21:10Mid Break-120:19:0820:24:0720

8A NEWS15.11.201720:21:20Mid Break-120:19:0820:24:0720

42A NEWS15.11.201720:58:16Casual20:57:1420:59:5720

43A NEWS15.11.201720:58:33Casual20:57:1420:59:5720

44A NEWS15.11.201720:58:42Casual20:57:1420:59:5720

45A NEWS15.11.201720:59:01Casual20:57:1420:59:5720

46A NEWS15.11.201722:26:58Mid Break-122:26:5422:33:5522
Worksheet: Sheet2v3

_......... continued in next posts due to post size limitations ( 10,000 characters incl. BB code )

[DocAElstein]

_____ Workbook: Data Sheet v3.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
45A NEWS15.11.201720:59:01Casual20:57:1420:59:5720

46A NEWS15.11.201722:26:58Mid Break-122:26:5422:33:5522

47A NEWS15.11.201722:27:18Mid Break-122:26:5422:33:5522

48A NEWS15.11.201722:27:36Mid Break-122:26:5422:33:5522

49A NEWS15.11.201722:28:06Mid Break-122:26:5422:33:5522

78A NEWS15.11.201722:53:03Mid Break-222:47:0222:54:0222

79A NEWS15.11.201722:53:18Mid Break-222:47:0222:54:0222

80A NEWS15.11.201722:53:42Mid Break-222:47:0222:54:0222

81A NEWS15.11.201722:57:15Casual22:57:1123:00:0522

87A NEWS15.11.201722:58:48Casual22:57:1123:00:0522

88A NEWS15.11.201722:59:08Casual22:57:1123:00:0522

89A NEWS18.11.201723:01:21Mid Break-123:01:1723:03:2123

90A NEWS18.11.201723:01:37Mid Break-123:01:1723:03:2123

91A NEWS18.11.201723:01:57Mid Break-123:01:1723:03:2123

140A NEWS18.11.201723:43:10Mid Break-323:33:5323:44:5523

141A NEWS18.11.201723:43:40Mid Break-323:33:5323:44:5523

142A NEWS18.11.201723:44:39Mid Break-323:33:5323:44:5523

143A NEWS18.11.201723:57:21Casual23:57:2123:59:5823

144A NEWS18.11.201723:57:31Casual23:57:2123:59:5823

145A NEWS18.11.201723:57:39Casual23:57:2123:59:5823

146A NEWS18.11.201723:57:57Casual23:57:2123:59:5823

150A NEWS18.11.201723:58:46Casual23:57:2123:59:5823

151A NEWS18.11.201723:59:06Casual23:57:2123:59:5823

152B NEWS16.11.201720:01:24Mid Break-220:01:2420:01:5020

153B NEWS16.11.201720:15:08Mid Break-120:15:0820:20:2020

196B NEWS16.11.201720:42:04Mid Break-220:31:4120:43:2420

197B NEWS16.11.201720:42:14Mid Break-220:31:4120:43:2420

198B NEWS16.11.201720:42:29Mid Break-220:31:4120:43:2420

199B NEWS16.11.201720:42:49Mid Break-220:31:4120:43:2420

200B NEWS16.11.201720:53:38Casual20:53:3821:00:0220
Worksheet: Sheet2v3

[DocAElstein]

_____ Workbook: Data Sheet v3.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGH
199B NEWS16.11.201720:42:49Mid Break-220:31:4120:43:2420

200B NEWS16.11.201720:53:38Casual20:53:3821:00:0220

201B NEWS16.11.201720:54:03Casual20:53:3821:00:0220

202B NEWS16.11.201720:54:14Casual20:53:3821:00:0220

203B NEWS16.11.201720:54:29Casual20:53:3821:00:0220

217B NEWS16.11.201720:58:13Casual20:53:3821:00:0220

218B NEWS16.11.201720:58:54Casual20:53:3821:00:0220

219B NEWS16.11.201720:59:29Casual20:53:3821:00:0220

220B NEWS18.11.201721:07:03Mid Break-221:07:0321:07:2921

221B NEWS18.11.201721:23:41Mid Break-321:23:4121:28:0621

222B NEWS18.11.201721:24:26Mid Break-321:23:4121:28:0621

256B NEWS18.11.201721:48:58Mid Break-721:46:2221:49:3521

257B NEWS18.11.201721:49:10Mid Break-721:46:2221:49:3521

258B NEWS18.11.201721:49:20Mid Break-721:46:2221:49:3521

259B NEWS18.11.201721:52:48Casual21:52:4821:59:5821

260B NEWS18.11.201721:53:08Casual21:52:4821:59:5821

269B NEWS18.11.201721:57:10Casual21:52:4821:59:5821

270B NEWS18.11.201721:57:53Casual21:52:4821:59:5821

271B NEWS18.11.201721:59:03Casual21:52:4821:59:5821

272B NEWS18.11.201721:59:25Casual21:52:4821:59:5821

273C NEWS17.11.201722:01:33Casual22:01:3322:03:1122

274C NEWS17.11.201722:02:01Casual22:01:3322:03:1122

275C NEWS17.11.201722:02:16Casual22:01:3322:03:1122

276C NEWS17.11.201722:02:51Casual22:01:3322:03:1122

277C NEWS17.11.201722:18:46Mid Break-122:18:4622:20:3122

292C NEWS17.11.201722:46:44Mid Break-222:41:2422:47:4422

293C NEWS17.11.201722:47:25Mid Break-222:41:2422:47:4422

294C NEWS17.11.201722:58:10Casual22:57:2622:59:5522

295
Worksheet: Sheet2v3

[DocAElstein]

Corresponding Sheet1 for the data Sheet2 of the last 3 posts:

_____ Workbook: Data Sheet v3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1DateChannelsstart timeNew Time


2
11.15.2017
A NEWS
20:07:00


3
11.15.2017
A NEWS
20:14:00


4
11.15.2017
A NEWS
20:21:00


5
11.15.2017
A NEWS
20:28:00


6
11.15.2017
A NEWS
20:35:00


7
11.15.2017
A NEWS
20:42:00


8
11.15.2017
A NEWS
20:49:00


9
11.15.2017
A NEWS
20:56:00


10
11.15.2017
A NEWS
22:49:00


11
11.15.2017
A NEWS
22:56:00


12
11.18.2017
A NEWS
23:15:00


13
11.18.2017
A NEWS
23:30:00


14
11.18.2017
A NEWS
23:45:00


15
11.16.2017
B NEWS
20:29:00


16
11.16.2017
B NEWS
20:59:00


17
11.18.2017
B NEWS
21:10:00


18
11.18.2017
B NEWS
21:20:00


19
11.18.2017
B NEWS
21:30:00


20
11.18.2017
B NEWS
21:40:00


21
11.18.2017
B NEWS
21:50:00


22
11.17.2017
C NEWS
22:13:00


23
11.17.2017
C NEWS
22:26:00


24
11.17.2017
C NEWS
22:39:00


25
11.17.2017
C NEWS
22:52:00


26
11.17.2017
D NEWS
23:13:00


27


28
Worksheet: Sheet1v3

[DocAElstein]

Full data Sheet1 data ( part 1)


Channel Date AdStart MidBreak Break_Start Break_End Hour
A NEWS 15.11.2017 20:19:12 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:19:32 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:19:49 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:20:01 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:20:47 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:21:10 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:21:20 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:21:30 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:21:46 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:22:55 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:23:07 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:23:42 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:23:57 Mid Break-1 20:19:08 20:24:07 20
A NEWS 15.11.2017 20:24:52 Mid Break-2 20:24:52 20:27:26 20
A NEWS 15.11.2017 20:25:07 Mid Break-2 20:24:52 20:27:26 20
A NEWS 15.11.2017 20:25:52 Mid Break-2 20:24:52 20:27:26 20
A NEWS 15.11.2017 20:26:52 Mid Break-2 20:24:52 20:27:26 20
A NEWS 15.11.2017 20:27:03 Mid Break-2 20:24:52 20:27:26 20
A NEWS 15.11.2017 20:42:50 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:43:02 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:43:32 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:43:57 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:44:12 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:44:24 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:44:40 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:44:56 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:45:27 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:46:36 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:47:36 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:47:46 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:48:21 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:48:36 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:48:59 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:49:35 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:49:47 Mid Break-3 20:42:46 20:50:06 20
A NEWS 15.11.2017 20:57:23 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:57:34 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:57:45 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:00 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:07 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:16 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:33 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:42 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:59:01 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 22:26:58 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:27:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:27:36 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:06 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:31 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:46 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:29:03 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:03 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:38 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:53 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:02 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:53 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:09 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:39 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:54 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:33:06 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:33:31 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:47:06 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:47:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:48:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:21 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:33 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:48 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:08 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:28 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:44 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:51:14 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:51:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:52:26 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:52:42 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:03 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:18 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:42 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:57:15 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:57:30 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:00 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:14 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:24 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:41 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:48 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:59:08 Casual 22:57:11 23:00:05 22
A NEWS 18.11.2017 23:01:21 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:01:37 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:01:57 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:02:27 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:02:57 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:16:35 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:16:56 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:20 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:37 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:52 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:02 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:17 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:26 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:38 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:13 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:43 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:53 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:20:00 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:20:25 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:00 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:17 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:47 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:54 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:22:09 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:22:19 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:33:57 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:28 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:43 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:53 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:01 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:11 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:46 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:01 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:11 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:23 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:38 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:53 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:03 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:15 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:52 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:59 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:00 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:24 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:39 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:40:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:20 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:35 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:20 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:51 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:43:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:43:40 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:44:39 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:57:21 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:31 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:39 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:57 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:13 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:23 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:39 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:46 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:59:06 Casual 23:57:21 23:59:58 23
B NEWS 16.11.2017 20:01:24 Mid Break-2 20:01:24 20:01:50 20
B NEWS 16.11.2017 20:15:08 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:33 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:43 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:58 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:16:33 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:16:48 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:04 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:19 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:34 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:44 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:02 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:27 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:42 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:12 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:32 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:47 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:31:41 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:12 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:37 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:52 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:02 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:22 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:32 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:57 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:34:12 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:34:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:35:34 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:19 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:39 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:54 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:37:13 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:37:44 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:09 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:24 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:59 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:39:39 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:40:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:40:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:34 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:14 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:29 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:53:38 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:03 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:14 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:29 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:43 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:03 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:28 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:38 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:48 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:18 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:33 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:58 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:28 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:43 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:53 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:58:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:58:54 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:59:29 Casual 20:53:38 21:00:02 20
B NEWS 18.11.2017 21:07:03 Mid Break-2 21:07:03 21:07:29 21
B NEWS 18.11.2017 21:23:41 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:26 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:36 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:57 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:07 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:17 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:47 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:12 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:27 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:52 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:02 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:32 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:47 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:36:02 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:36:37 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:36:56 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:26 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:36 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:51 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:28 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:43 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:53 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:39:18 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:39:38 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:40:08 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:40:33 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:41:25 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:45:02 Mid Break-6 21:44:41 21:45:33 21
B NEWS 18.11.2017 21:46:22 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:46:48 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:47:08 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:47:23 ..................................cont. in next post

[DocAElstein]

Full data input sheet2 cont........


.................................................. .. Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:33 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:58:42 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 20:59:01 Casual 20:57:14 20:59:57 20
A NEWS 15.11.2017 22:26:58 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:27:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:27:36 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:06 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:31 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:28:46 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:29:03 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:03 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:38 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:30:53 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:02 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:18 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:31:53 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:09 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:39 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:32:54 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:33:06 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:33:31 Mid Break-1 22:26:54 22:33:55 22
A NEWS 15.11.2017 22:47:06 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:47:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:48:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:21 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:33 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:49:48 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:08 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:28 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:50:44 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:51:14 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:51:51 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:52:26 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:52:42 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:03 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:18 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:53:42 Mid Break-2 22:47:02 22:54:02 22
A NEWS 15.11.2017 22:57:15 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:57:30 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:00 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:14 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:24 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:41 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:58:48 Casual 22:57:11 23:00:05 22
A NEWS 15.11.2017 22:59:08 Casual 22:57:11 23:00:05 22
A NEWS 18.11.2017 23:01:21 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:01:37 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:01:57 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:02:27 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:02:57 Mid Break-1 23:01:17 23:03:21 23
A NEWS 18.11.2017 23:16:35 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:16:56 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:20 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:37 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:17:52 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:02 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:17 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:26 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:18:38 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:13 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:43 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:19:53 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:20:00 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:20:25 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:00 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:17 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:47 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:21:54 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:22:09 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:22:19 Mid Break-2 23:16:35 23:22:43 23
A NEWS 18.11.2017 23:33:57 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:28 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:43 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:34:53 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:01 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:11 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:35:46 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:01 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:11 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:23 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:38 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:36:53 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:03 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:15 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:52 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:37:59 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:00 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:24 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:39:39 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:40:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:20 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:41:35 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:20 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:42:51 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:43:10 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:43:40 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:44:39 Mid Break-3 23:33:53 23:44:55 23
A NEWS 18.11.2017 23:57:21 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:31 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:39 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:57:57 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:13 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:23 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:39 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:58:46 Casual 23:57:21 23:59:58 23
A NEWS 18.11.2017 23:59:06 Casual 23:57:21 23:59:58 23
B NEWS 16.11.2017 20:01:24 Mid Break-2 20:01:24 20:01:50 20
B NEWS 16.11.2017 20:15:08 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:33 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:43 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:15:58 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:16:33 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:16:48 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:04 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:19 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:34 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:17:44 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:02 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:27 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:18:42 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:12 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:32 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:19:47 Mid Break-1 20:15:08 20:20:20 20
B NEWS 16.11.2017 20:31:41 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:12 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:37 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:32:52 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:02 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:22 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:32 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:33:57 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:34:12 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:34:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:35:34 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:19 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:39 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:36:54 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:37:13 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:37:44 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:09 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:24 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:38:59 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:39:39 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:40:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:40:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:34 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:41:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:04 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:14 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:29 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:42:49 Mid Break-2 20:31:41 20:43:24 20
B NEWS 16.11.2017 20:53:38 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:03 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:14 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:29 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:54:43 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:03 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:28 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:38 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:55:48 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:18 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:33 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:56:58 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:28 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:43 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:57:53 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:58:13 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:58:54 Casual 20:53:38 21:00:02 20
B NEWS 16.11.2017 20:59:29 Casual 20:53:38 21:00:02 20
B NEWS 18.11.2017 21:07:03 Mid Break-2 21:07:03 21:07:29 21
B NEWS 18.11.2017 21:23:41 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:26 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:36 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:24:57 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:07 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:17 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:25:47 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:12 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:27 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:26:52 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:02 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:32 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:27:47 Mid Break-3 21:23:41 21:28:06 21
B NEWS 18.11.2017 21:36:02 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:36:37 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:36:56 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:26 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:36 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:37:51 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:28 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:43 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:38:53 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:39:18 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:39:38 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:40:08 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:40:33 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:41:25 Mid Break-5 21:36:02 21:42:00 21
B NEWS 18.11.2017 21:45:02 Mid Break-6 21:44:41 21:45:33 21
B NEWS 18.11.2017 21:46:22 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:46:48 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:47:08 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:47:23 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:47:58 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:48:23 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:48:43 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:48:58 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:49:10 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:49:20 Mid Break-7 21:46:22 21:49:35 21
B NEWS 18.11.2017 21:52:48 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:53:08 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:53:23 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:53:58 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:54:53 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:55:13 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:55:28 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:55:40 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:56:40 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:56:56 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:57:10 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:57:53 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:59:03 Casual 21:52:48 21:59:58 21
B NEWS 18.11.2017 21:59:25 Casual 21:52:48 21:59:58 21
C NEWS 17.11.2017 22:01:33 Casual 22:01:33 22:03:11 22
C NEWS 17.11.2017 22:02:01 Casual 22:01:33 22:03:11 22
C NEWS 17.11.2017 22:02:16 Casual 22:01:33 22:03:11 22
C NEWS 17.11.2017 22:02:51 Casual 22:01:33 22:03:11 22
C NEWS 17.11.2017 22:18:46 Mid Break-1 22:18:46 22:20:31 22
C NEWS 17.11.2017 22:18:56 Mid Break-1 22:18:46 22:20:31 22
C NEWS 17.11.2017 22:19:32 Mid Break-1 22:18:46 22:20:31 22
C NEWS 17.11.2017 22:41:24 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:41:34 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:42:01 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:42:31 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:43:06 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:43:16 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:43:26 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:44:07 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:44:49 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:45:26 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:46:24 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:46:34 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:46:44 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:47:25 Mid Break-2 22:41:24 22:47:44 22
C NEWS 17.11.2017 22:58:10 Casual 22:57:26 22:59:55 22

[DocAElstein]

Version 3 code for Haider, for this post:
http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11148&viewfull=1#post11148


Option Explicit '
Sub HaiderAdSlots_v3() ' http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11124&viewfull=1#post11124
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("Sheet1v3"): Set Ws2 = ThisWorkbook.Worksheets("Sheet2v3")
Dim Lr1 As Long, Lr2 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "").Row: Let Lr2 = Ws1.Range("A" & Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row & "").Row
'1b) data arrays, original data
Dim arrInSht2() As Variant, arrOutSht1() As Variant
Let arrInSht2() = Ws2.Range("A1:G" & Lr2 + 1 & "").Value2 ' !!! I need +1 as a "bodge workaroung to prevent an index out of range error --- here
Let arrOutSht1() = Ws1.Range("A1:C" & Lr1 & "").Value2
'1b)(ii) extra "column" for outout
ReDim Preserve arrOutSht1(1 To Lr1, 1 To 4) ' we may add a last dimension, but must keep the others the same as they were
Rem 2 Group ident arrays, for convenience
'2a) an array of the idents for all data rows in output sheet1
Dim arrOutId() As String
ReDim arrOutId(1 To Lr1)
Dim cnt As Long
For cnt = 2 To Lr1 ' Channel Date in Long number form Hour as number
Let arrOutId(cnt) = arrOutSht1(cnt, 2) & " | " & arrOutSht1(cnt, 1) & " | " & CLng(Hour(arrOutSht1(cnt, 3))) ' add to array of all idents in rows 2 to last row
Next cnt
'2b) idents for input historical data, includung an additonal arrray of just the unique ident values
Dim arrInId() As String
ReDim arrInId(1 To Lr2 + 1)
For cnt = 2 To Lr2 ' Channel Date in Long number form Hour as number
Let arrInId(cnt) = arrInSht2(cnt, 1) & " | " & arrInSht2(cnt, 2) & " | " & CLng(arrInSht2(cnt, 7)) ' add to array of all idents in rows 2 to last row
Dim strEnucsIds As String: ' a string of unique idents to be used to create an additonal arrray of just the unique ident values
If InStr(1, strEnucsIds, arrInId(cnt), vbBinaryCompare) = 0 Then Let strEnucsIds = strEnucsIds & arrInId(cnt) & "####"
Next cnt
Let strEnucsIds = Left(strEnucsIds, Len(strEnucsIds) - 4) ' takes off last "####"
Dim arrEnucsIds() As String: Let arrEnucsIds() = Split(strEnucsIds, "####", -1, vbBinaryCompare) ' additonal arrray of just the unique ident values
Dim CntIds As Long: Let CntIds = UBound(arrEnucsIds()) + 1 ' +1 because the index numbers of array generated by Split function goes like 0 1 2 3 4 ... etc. So the total number of elements is 1 more than the ubound: .... (Ubound gives the index number of the last element, not necerssarily the numberr of elements)
'Debug.Print strEnucsIds
'2c) We know the number of unique idents , so can assign an array, a groupings array, to hold each group of times
Dim arrGrpTimes() As Variant ' I must use variant, as that is the only thing that can hild an array - i will be putting arrasy of the AdStart times in the second dimension ("second column")
ReDim arrGrpTimes(1 To CntIds, 1 To 2) ' The first column has the unique ID, and the second column will be itself an array of the historical AdStart times for that group
Rem 3 Looping to build groupings array
Dim HisCnt As Long ' MAIN LOOP Count for rows of historical data ================================================
Let HisCnt = 1 ' this is so +1 gives the start at row 2, so as not to consider the header ....**
Do While HisCnt < Lr2
Dim GrpCnt As Long ' this will be used for the first dimension("row") of our
Dim strTimes As String: Let strTimes = " " ' reset for next group of AdStart times
Let GrpCnt = GrpCnt + 1 ' reset to index/first dimension("row") next group of AdStart times
Do ' This INNER LOOP will be repeated for each group -------------------------INNER LOOP
Let HisCnt = HisCnt + 1 ' this effectively "goes down" each row in data Sheet2 - starting at row 2 ....**
Let strTimes = strTimes & arrInSht2(HisCnt, 3) & " "

Loop While arrInId(HisCnt + 1) = arrInId(HisCnt) ' !!! ---here --INNER LOOP
Let strTimes = Trim(strTimes) ' takes off leading and trailing spaces
'Debug.Print strTimes
' at the end of each inner loop, we have the data needed to add the AdStart data for this group
Let arrGrpTimes(GrpCnt, 1) = arrEnucsIds(GrpCnt - 1) ' -1 is because arrEnucsIds() starts at index number 0 , like index numbers go 0 1 2 3 4 ... etc.
Dim arrTemp() As String ' temporary array to build each array of AdStart times
Let arrTemp() = Split(strTimes, " ", -1, vbBinaryCompare)
Let arrGrpTimes(GrpCnt, 2) = arrTemp()
Loop ' MAIN LOOP Count for rows of historical data ================================================

Rem 4 Going through ("down") the output, Sheet1, data , and adding a New Time at each "row"
For cnt = 2 To Lr1 ' MAIN LOOP for Count for rows in Sheet1 ================================================== =
'4b) determine to which group the "row" belongs
Dim MtchRes As Variant ' The next line will either return a whole number of the "position along" that it fids a match, or it will return a VBA error type. So a variant for the Variable must be used
Let MtchRes = Application.Match(arrOutId(cnt), arrEnucsIds(), 0) ' return the position along of a match ( looking for arrOutId(cnt) , in the array of unique Ids arrEnucsIds() , 0 indicates excact match ) ....._- note the array of unique Ids is determined from the Ids in input historical data
If Not IsError(MtchRes) Then '4b)(i) - time to get a time, form the array { "20:19:12" , "20:19:32" , "20:49:12" , ….etc } of times for this Id group
Dim arrTempTimes() As String ' for the array , { "20:19:12" ,........ } , of times
Let arrTempTimes() = arrGrpTimes(MtchRes, 2) ' I can assign a dynamic array to any other array, as long as the types, ( String) in this case are the same. The wanted array is in the second column of the array, arrGrpTimes()
Rem 5 "Getting the random times bit"...
Dim RndIndx As Long: Randomize: Let RndIndx = Int(Rnd() * (UBound(arrTempTimes()) + 1)) ' like IntegerOf(Rnd()*(N+1))
Let arrOutSht1(cnt, 4) = arrTempTimes(RndIndx)
Else '4b(ii). This is the case of no unique Id as determined from the Ids in input historical data, arrEnucsIds() ....._- so this may occur if ..." if in any case there is no spot aired in Sheet2 on a specific channel, date and timeslot then New Time will be same as start time...."
Let arrOutSht1(cnt, 4) = arrOutSht1(cnt, 3) ' ...".....if in any case there is no spot aired in Sheet2 on a specific channel, date and timeslot then New Time will be same as start time....."
End If

Next cnt ' MAIN LOOP for Count for rows in Sheet1 ================================================== ===========

Rem 6 Output test
Let ThisWorkbook.Worksheets("OutputTestv3").Range("A1").Resize(UBound(arrOutSht1(), 1), 4).Value = arrOutSht1()

End Sub


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

A typical test run of the last routine gives this, ( using the test data from the last few posts , #158 - #163 )

_____ Workbook: Data Sheet v3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F

1DateChannelsstart timeNew Time


2
11.15.2017
A NEWS
20:07:00
20:21:20


3
11.15.2017
A NEWS
20:14:00
20:20:01


4
11.15.2017
A NEWS
20:21:00
20:44:24Duplicate


5
11.15.2017
A NEWS
20:28:00
20:58:33


6
11.15.2017
A NEWS
20:35:00
20:42:50


7
11.15.2017
A NEWS
20:42:00
20:44:24Duplicate


8
11.15.2017
A NEWS
20:49:00
20:58:07


9
11.15.2017
A NEWS
20:56:00
20:21:10


10
11.15.2017
A NEWS
22:49:00
22:30:03


11
11.15.2017
A NEWS
22:56:00
22:47:51


12
11.18.2017
A NEWS
23:15:00
23:57:31


13
11.18.2017
A NEWS
23:30:00
23:57:57


14
11.18.2017
A NEWS
23:45:00
23:16:35


15
11.16.2017
B NEWS
20:29:00
20:32:12


16
11.16.2017
B NEWS
20:59:00
20:18:27


17
11.18.2017
B NEWS
21:10:00
21:52:48


18
11.18.2017
B NEWS
21:20:00
21:24:26


19
11.18.2017
B NEWS
21:30:00
21:38:43


20
11.18.2017
B NEWS
21:40:00
21:53:58


21
11.18.2017
B NEWS
21:50:00
21:26:12


22
11.17.2017
C NEWS
22:13:00
22:02:01


23
11.17.2017
C NEWS
22:26:00
22:46:34


24
11.17.2017
C NEWS
22:39:00
22:42:31


25
11.17.2017
C NEWS
22:52:00
22:43:26


26
11.17.2017
D NEWS
23:13:00
23:13:00


27


28
Worksheet: OutputTestv3

File: "Data Sheet v3.xls" : https://app.box.com/s/pym52m1gslq5cynqgob8izltu6ztesim

[DocAElstein]

Notes in support of these excelfox Threads and posts:
http://www.excelfox.com/forum/showthread.php/2334-Tests-Windows-Vista-and-Excel
http://www.excelfox.com/forum/showthread.php/1897-Testing-Excel-and-Sannce-1080N-and-Computer-CMS-Software
https://www.ebay.de/itm/323782698418?ul_noapp=true , _ https://imgur.com/Xq2hih2


First Cloud attempts.



Tests Friday, 7th June 2019.

OK I make Today two tries on one computer : Computer Acer Aspire 4810TZG Vista Operating System
_1 Try one: My computer is connected to the internet using the same router as that to which the Sannce 1080N Receiver is successfully connected . (German Telekom Speedport W504V Router LAN RJ45 Internet connection)
Delete a desktop "Deinstaller CMS" icon



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Notes in support of these main Threads and posts:
http://www.excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in
https://excel.tips.net/T002042_Inserting_and_Copying_Rows.html
*** see refs also


I tend to think of the Excel VBA Range.Insert method*** as primarily something that …… makes a space to put new range in ……( https://tinyurl.com/y2cup4o8 )
If something happens to be in the clipboard when you use this code line, then VBA makes some assumption that you wanted what is in the clipboard put in the space. Exactly what it decides to do takes a book of explanation, ( http://www.excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441 ). It is left for us to figure out as there is no documentation that I know of
In the simplest case of having a single row in the clipboard, and using the Range.Insert to make a whole row as a space, then the results are as you expect, since the obvious choice that Excel makes is to assume you want to put that copied row in the new row space.
That is what Allen Wyatt's*** first routine does. It inserts a new empty row at the active row ( or row containing the active cell ) , but also what is in the clipboard, ( the original row ) , is put into this new row. What actually is happening is that the original row has been shifted down. A copy of that original ( which was firstly made ) , is put in the new row space
In the second routine, he uses the Range.Insert method with nothing in the clipboard so that it just makes the row space, ( this time he inserts that space one row down ). Then he copies the row and pastes it into the new row space.
So his two routines demonstrate well the points I am trying to make.

To copy just some of a row to a new row:
Using something similar to the second routine is the better alternative for only copying some of the original row to the new row space. ( The other alternative of trying to manipulate and then predict how the Range.Insert will handle a modified clipboard content is certainly possible and academically interesting, but might be a little advanced if you are VBA beginner, especially as the various Bugs and unknowns in the various Microsoft clipboards has been proven in recent years to be beyond the understanding of the Microsoft programmers themselves!! )
So, for example, the general idea would be
_1,
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Or, as example
ActiveCell.Offset(1, 0).EntireRow.Resize(1, 14).Insert Shift:=xlDown
_2, The simplest way, or first idea that springs to mind for me, is to copy the row info you want to a simple array, and then manipulate it to remove/ leave blank the info that you do not want, then paste that into the space.

Here is a couple of routine examples, here I want just columns A to F from a row A to H

Sub Testies2a()
Rem 1 make a space by moving ( Shift -ing ) the rows down
ActiveCell.Offset(1, 0).EntireRow.Resize(1, 8).Insert Shift:=xlDown ' when I Re size a range, it starts at the top left of the range, which will be in the first column either for a row or for a range starting in column 1
Rem 2 put the current active row in an array
Dim arrAH() As Variant ' The reason I need Variant is that the next line allows me to capture an entire range in one go, using the .Value property which returns the values in Variant type elements. So the type definition must match.
Let arrAH() = ActiveCell.EntireRow.Resize(1, 8).Value ' so my array now holds cell values from columns A-H ( columns 1-8 )
'2b remove the values you do not want
Let arrAH(1, 7) = "": Let arrAH(1, 8) = ""
Rem 3 paste out modified array
Let ActiveCell.Offset(1, 0).EntireRow.Resize(1, 8).Value = arrAH() ' VBA lets me do the opposite of the capture to paste out array values in oone go
End Sub
Sub Testies2b()
Rem 1 make a space by moving ( Shift -ing ) the rows down
ActiveCell.Offset(1, 0).EntireRow.Resize(1, 8).Insert Shift:=xlDown ' when I Re size a range, it starts at the top left of the range, which will be in the first column either for a row or for a range starting in column 1
Rem 2 put the current active row in an array
Dim arrAH() As Variant ' The reason I need Variant is that the next line allows me to capture an entire range in one go, using the .Value property which returns the values in Variant type elements. So the type definition must match.
Let arrAH() = ActiveCell.EntireRow.Resize(1, 6).Value ' so my array now holds cell values from columns A-F ( columns 1-6 )
Rem 3 paste out modified array
Let ActiveCell.Offset(1, 0).EntireRow.Resize(1, 6).Value = arrAH() ' VBA lets me do the opposite of the capture to paste out array values in oone go
End Sub


As example, if you start with this, with say cell B2 selected:
Row\Col
A
B
C
D
E
F
G
H
I

1A1B1C1D1E1F1G1H1I1


2A2B2C2D2E2F2G2H2I2


3A3B3C3D3E3F3G3H3I3


4A4B4C4D4E4F4G4H4I4


Then using that test data, after running either routine you will get this:

Row\Col
A
B
C
D
E
F
G
H
I

1A1B1C1D1E1F1G1H1I1


2A2B2C2D2E2F2G2H2I2


3A2B2C2D2E2F2I3


4A3B3C3D3E3F3G3H3I4


_._________________________________


The next routine, I think will do something close to your specific question, the row to be copied is columns A-N , and you want G and H left blank


Sub Testies3()
Rem 1 make a space by moving ( Shift -ing ) the rows down
ActiveCell.Offset(1, 0).EntireRow.Resize(1, 14).Insert Shift:=xlDown '
Rem 2 put the current active row in an array
Dim arrAH() As Variant '
Let arrAH() = ActiveCell.EntireRow.Resize(1, 14).Value ' so my array now holds cell values from columns A-N ( columns 1-14 )
'2b remove the values you do not want
Let arrAH(1, 7) = "": Let arrAH(1, 8) = ""
Rem 3 paste out modified array
Let ActiveCell.Offset(1, 0).EntireRow.Resize(1, 14).Value = arrAH() '
End Sub


ref:
Allen Wyatt *** https://excel.tips.net/T002042_Inserting_and_Copying_Rows.html
*** https://docs.microsoft.com/en-us/office/vba/api/excel.range.insert

[TallPaulUK]

Hi Alan... Thank you so much for the code... It does exactly what I wanted..

Also, thank you for your explanation as this has helped be understand more of what the code does... sometime this is more important than the solution itself.

Keep up the good work.

Thanks again

Paul

[DocAElstein]

You're welcome , Paul , thanks for the feedback
:)

[DocAElstein]

In support of this Thread in main Forums:
http://www.excelfox.com/forum/showthread.php/2340-Removed-highlighted-colour-based-on-condition

A macro recording example to get some coding to help answer this……
all files are located in desktop
vba is placed ........ all files are located in desktop
vba is placed in seperate file
only 1 file is opened and that is vba code placed file so for this process we have to open the file as per condition and after the process completed all files should be saved and closed except vba placed file
If column R of 1.xls file is not in minus(-1,-0.5 or xyz any negative number) then see the column E data of 1.xls and open 2.xlsx and match column E of 1.xls with column A of 2.xlsx
and if it matches then look for any highlighted colour in that row and if any highlighted cell in that row is found then remove the highlighted colour and save the file and close all the file




Open Excel. ( I have Office 2007 ).

Turn on the macro recorder
Turn On Macro Recorder.jpg : https://imgur.com/uZkZWg1
( I use the default macro name and place for the coding to be stored )
Use default macro name and place where macro is stored.jpg : https://imgur.com/rR8UkT1

I open a new file.
Open new file.jpg : https://imgur.com/10pnrBL
( I am in Excel 2007, so I end up with a .xlsx file
New xlsx File.JPG : https://imgur.com/vvqEC1w

I save this file on the desktop, giving it the name "MainMacroFile"
Save As.jpg : https://imgur.com/PrnZhAW
Save As xlsx.JPG : https://imgur.com/PrnZhAW

I resave as a file to hold macros:
Save As xlsm.JPG https://imgur.com/5hVZAld


I open a new file
Open new file.jpg : https://imgur.com/vvqEC1w
( I am in Excel 2007, so I end up with a .xlsx file
New xlsx File.JPG : https://imgur.com/vvqEC1w
I save this file on the desktop, giving it the name "1"
Save As.jpg : https://imgur.com/PrnZhAW
Save As 1_xlsx.JPG https://imgur.com/y2uMg0i
I resave as a 1.xls
Save As.jpg : https://imgur.com/PrnZhAW
Save As 1_xls.JPG : https://imgur.com/iylw8r7

I close the file "1.xls"
Close 1_xls.jpg : https://imgur.com/vJtdLHo
I open the file "1.xls"
Open 1_xls.jpg : https://imgur.com/de2MGkt
Open 1_xls.jpg : https://imgur.com/zafLOTd

I now take some actions, …. which are similar to your …. If column R of 1.xls file is not in minus(-1,-0.5 or xyz any negative number) then see the column E data of 1.xls and open 2.xlsx and match column E of 1.xls with column A of 2.xlsx
and if it matches then look for any highlighted colour in that row and if any highlighted cell in that row is found …..
What I actually did was
_ Put some positive numbers in column R
_ Put some letters in column E
_ Put some highlight in column E
Add some numbers letters and highlighting.JPG : https://imgur.com/6ZYeaxU
_ I take some of the highlighting off
Take some highlighting off.jpg : https://imgur.com/Z1Rk9HD
I save the file "1.xls"
Save 1_xls.jpg : https://imgur.com/FmLrhjZ
I close the file "1.xls"
Close 1_xls.jpg : https://imgur.com/R6eqv1m

I make a new file, "2.xlsx" , on the desktop
New xlsx File.JPG : https://imgur.com/vvqEC1w
Save As 2_xlsx.JPG : https://imgur.com/mHacZ74

I close the file and open it
Close 2_xlsx.jpg : https://imgur.com/tReoAJG
Open 2_xlsx.jpg : https://imgur.com/jmsqNY1
Open 2_xlsx.jpg : https://imgur.com/J3XPhz5

I put a letter in column A of "2.xlsx"
Put a letter in column A of 2_xlsx.JPG : https://imgur.com/9o8PTYQ
I save the file "2.xlsx"
Save 2_xlsx.jpg : https://imgur.com/ehSxG6b
I close the file "2.xlsx"
Close 2_xlsx.jpg : https://imgur.com/YyRmhfW

I now stop the macro recorder
Stop macro recorder.JPG : https://imgur.com/NrcDQS4
Stop macro recorder.JPG : https://imgur.com/WRgy3mB


Find the macro just recorded and click on Step Into
Find macro just recorded.JPG : https://imgur.com/xK3abHT
Find macro just recorded.JPG : https://imgur.com/34U5nm3
( Alternatively hit Alt+F8 )

You can then see the recorded macro
Recorded Macro.JPG : https://imgur.com/Mo0vfHi


I include the code below, but have also added some 'Comments ( ' Rems) to show the steps which I manually made above


Sub Makro1()
'
' Makro1 Makro
'

'
' Rem I open a new file.
Workbooks.Add
' Rem I save this file on the desktop, giving it the name "MainMacroFile"
ChDir "C:\Users\Elston\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\Elston\Desktop\MainMacroFile.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Rem I resave as a file to hold macros
ActiveWorkbook.SaveAs Filename:="C:\Users\Elston\Desktop\MainMacroFile.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

' Rem I open a new file.
Workbooks.Add
' Rem I save this file on the desktop, giving it the name "1"
ActiveWorkbook.SaveAs Filename:="C:\Users\Elston\Desktop\1.xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
' Rem I resave as a 1.xls
ActiveWorkbook.SaveAs Filename:="C:\Users\Elston\Desktop\1.xls", FileFormat _
:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
' Rem I close the file "1.xls"
ActiveWorkbook.Close
' Rem I open the file "1.xls"
Workbooks.Open Filename:="C:\Users\Elston\Desktop\1.xls"

' Rem I now take some actions, …. ....... If column R of 1.xls file is not in minus(-1,-0.5 or xyz any negative number) then see the column E data of 1.xls and open 2.xlsx and match column E of 1.xls with column A of 2.xlsx
Range("R1").Select
ActiveCell.FormulaR1C1 = "1"
Range("R2").Select
ActiveCell.FormulaR1C1 = "2"
Range("R3").Select
ActiveCell.FormulaR1C1 = "3"
Range("E1").Select
ActiveCell.FormulaR1C1 = "a"
Range("E2").Select
ActiveCell.FormulaR1C1 = "b"
Range("E3").Select
ActiveCell.FormulaR1C1 = "c"
Range("E4").Select
ActiveCell.FormulaR1C1 = "d"
Range("E1:E4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' Rem _ I take some of the highlighting off
Range("E2").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E3").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' Rem I save the file "1.xls"
ActiveWorkbook.Save
' Rem I close the file "1.xls"
ActiveWorkbook.Close

' Rem I make a new file, "2.xlsx" , on the desktop
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Users\Elston\Desktop\2.xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
' Rem I close the file and open it
ActiveWorkbook.Close
Workbooks.Open Filename:="C:\Users\Elston\Desktop\2.xlsx"

' Rem I put a letter in column A of "2.xlsx"
Range("A4").Select
ActiveCell.FormulaR1C1 = "d"
Range("A5").Select
' Rem I save the file "2.xlsx"
ActiveWorkbook.Save
' Rem I close the file "2.xlsx"
ActiveWorkbook.Close


' Rem I now stop the macro recorder
End Sub

[DocAElstein]

In support of answer to this main excelfox Excel Forum Thread: http://www.excelfox.com/forum/showthread.php/2343-PARCOURIR-UNE-COLONNE-ET-COMPARER-LES-VALEURS-EN-VBA?p=11188#post11188

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S

1a
1


2b
2


3c
3


4d
Worksheet: Tabelle1






_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1


2


3


4d


5


6


7


8


9


10


11


12
Worksheet: Tabelle1








The two files shown above are attatched below:

[DocAElstein]

In support of answer to this main excelfox Excel Forum Thread: http://www.excelfox.com/forum/showthread.php/2343-PARCOURIR-UNE-COLONNE-ET-COMPARER-LES-VALEURS-EN-VBA?p=11188#post11188

Sample file:
_____ Workbook: MainMacroFile.xlsm ( Using Excel 2007 32 bit )

<tbody>
Row\Col

A


B


C


D


E




1

expiry date
mark Brand
value





2


27.06.2019

a

1






3


26.06.2019

b

2






4


25.06.2019

c

3






5


24.06.2019

d

4






6


23.06.2019

e

5






7


22.06.2019

f

6






8


21.06.2019

g

7






9


20.06.2019

h

8






10


27.06.2019

i

9






11


26.06.2019

j

10






12









13







</tbody>
Worksheet: Tabelle1


_____ Workbook: MainMacroFile.xlsm ( Using Excel 2007 32 bit )

<tbody>
Row\Col

A


B


C


D


E




1

expiry date
mark Brand
value





2


=TODAY() -(ROW()-3)

a

1






3


=TODAY() -(ROW()-3)

b

2






4


=TODAY() -(ROW()-3)

c

3






5


=TODAY() -(ROW()-3)

d

4






6


=TODAY() -(ROW()-3)

e

5






7


=TODAY() -(ROW()-3)

f

6






8


=TODAY() -(ROW()-3)

g

7






9


=TODAY() -(ROW()-3)

h

8






10


27.06.2019

i

9






11


26.06.2019

j

10






12









13







</tbody>
Worksheet: Tabelle1

Data analysis using VBA arrays
I personally like to work with VBA arrays. So I put our data into an array, with this code line:
ThisWorkbook.Worksheets.Item(1).Range("A1").CurrentRegion.Value2
You can see what is in our arrData() if you step through the coding from within the VB Editor ( Hit key F8 with the cursor in the routine) , then before the run is finished and after the above code line ( Let arrData() ThisWorkbook.Worksheets.Item(1).Range("A1").CurrentRegion.Value2 ) , select any arrData(), and then hit key F9. This will add the array, arrData() to a watch window:
F9 arrData().JPG: https://imgur.com/02xZas2
F9 __ arrData().JPG: https://imgur.com/1QKwEb4
The CurrentRegion
The CurrentRegion range property of a range ( in this example the range is range A1 ), returns the range connected to that range which can be bordered by either empty columns and rows, or the spreadsheet boundaries. In this example , the CurrentRegion range associated with range A1, is that range enclosed by row 12, column D and the left and top spreadsheet boundaries
_____ Workbook: MainMacroFile.xlsm ( Using Excel 2007 32 bit )

<tbody>
Row\Col

A


B


C


D


E




1

expiry date
mark Brand
value





2


27.06.2019

a

1






3


26.06.2019

b

2






4


25.06.2019

c

3






5


24.06.2019

d

4






6


23.06.2019

e

5






7


22.06.2019

f

6






8


21.06.2019

g

7






9


20.06.2019

h

8






10


27.06.2019

i

9






11


26.06.2019

j

10






12









13







</tbody>
Worksheet: Tabelle1

So this is effectively what our arrData() looks like:

<tbody>
expiry date
mark Brand
value



43643

a

1




43642

b

2




43641

c

3




43640

d

4




43639

e

5




43638

f

6




43637

g

7




43636

h

8




43643

i

9




43642

j

10


</tbody>

So , for example, arrData(5, 2) has a value of d, and arrData(5, 3) value is 4
Effectively a VBA array is a fixed size spreadsheet, ( usually much smaller than a full spreadsheet ) . You cannot see its contents directly, but you can see it using the Watch Window, as discussed above. It can only have limited infomation - you cannot hold in it things like cell size and color infomation. We are using it to hold the .Value2 . .Value2 is the most fundamental value. .Value2 is usually the simple value that you see in the spreadsheet. One exception to this is with dates. The .Value2 of a date is that number held by Excel internally, which is a whole number starting at 1 for the date of January 1, 1900, and increasing by 1 for every day since then.
So , for example, the .Value2 of January 5, 1900 is 5
The .Value2 for the current day as I write this is 43643,which I can see if I step through the routine which is given in the example file , and hover over the variable , DteAujourd_hui , which the coding fills with the whole number part of the current date and time
43643.jpg : https://imgur.com/mMC42MI
The exact number you see will likely be slightly different , depending on where you are and when you run the routine

[DocAElstein]

In support of this main Forum Thread:
http://www.excelfox.com/forum/showthread.php/2349-Find-percentage-by-vba?p=11393#post11393

Test file: target1.xlsx
_____ Workbook: target1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1


2
1
100
1
2


3
2
100
1
2


4
Worksheet: Tabelle1


Test file: (Before) target2.xlsx
_____ Workbook: target2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1


2
1
1234


3
3
1234


4
Worksheet: Tabelle1


Now run macro Sub Vixer() , which should fulfil this logic...
...If column E of target1.xlsx matches with column A of target2.xlsx then look column O of target1.xlsx is greater or column P of target1.xlsx is greater, whichever is greater calculate the 0.50% of that and multiply that with column K of target1.xlsx and paste the result to target2.xlsx from column C(if column C has data then column D and if column D has data then column E and so on...) the result should be in minus means whatever is the result put minus sign in that along with result

The main macro file , macro.xlsm , gets populated thus:

_____ Workbook: macro.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1column A of target2.xlsxcolumn E of target1.xlsxcolumn K of target1.xlsxcolumn O of target1.xlsxcolumn P of target1.xlsx


2
1
1
100
1
2


3
3
2
100
1
2


4
Worksheet: Tabelle2


The test file, target2.xlsx , now gets changed to this
Test file results After target2.xlsx

_____ Workbook: target2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1


2
1
1234
-1


3
3
1234


4
Worksheet: Tabelle1

macro_ xlsm from Alan.jpg : https://imgur.com/pyf13dA
2347)

[DocAElstein]

In support and appendix for this Thread Post:
http://www.excelfox.com/forum/showthread.php/2349-Find-percentage-by-vba?p=11395#post11395
Data Files from Vixer

target2.xlsx
_____ Workbook: target2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1Symbol


2ACC


3TCS


4MARICO


5M&MFIN


6TATAELXSI


7BAJAJ-AUTO


8BANKBARODA


9


10


11


12
Worksheet: Sheet1






target1.xls
_____ Workbook: target1.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXY
1UserIdAccountIdEntityNameExchg-SegSymbolInstrument NameOption TypeNetBuyValueNetSellValueNetValueNetBuyQtyNetSel lQtyNetQtyBEPSellAvgPriceBuyAvgPriceLastTradedPric eMarkToMarketRealized MarkToMarketUnrealized MarkToMarketEL MarkToMarketTrading SymbolClient ContextSeries/ExpiryStrike Price

2WC5758NSEMINDTREEEQ 765.00760.10-4.9014760.10765.00760.65-4.9-4.9-4.9MINDTREE-EQEQ

3WC5758NSEBHELEQ 135.3067.65-67.6524167.6567.6567.6567.5-0.15-0.15-0.15BHEL-EQEQ

4WC5758NSESIEMENSEQ 2540.402504.10-36.30241252.051270.201253-36.3-36.3-36.3SIEMENS-EQEQ

5WC5758NSESUNTVEQ 945.70939.60-6.1024469.80472.85473.6-6.1-6.1-6.1SUNTV-EQEQ
Worksheet: ap-Sheet1

_____ Workbook: target1.xls ( Using Excel 2007 32 bit )

UserIdAccountIdEntityNameExchg-SegSymbol

WC5758NSEMINDTREE

WC5758NSEBHEL

WC5758NSESIEMENS

WC5758NSESUNTV

WC5758NSERELCAPITAL

WC5758NSEJSWSTEEL

WC5758NSETVSMOTOR

WC5758NSERECLTD

WC5758NSEPIDILITIND

WC5758NSEVOLTAS

WC5758NSETITAN

WC5758NSEPNB

WC5758NSEOFSS

WC5758NSEYESBANK

WC5758NSEMFSL

WC5758NSEPETRONET

WC5758NSEHDFC

WC5758NSEPVR

WC5758NSESUNPHARMA

WC5758NSENIITTECH

WC5758NSEGRASIM

WC5758NSELICHSGFIN

WC5758NSEMANAPPURAM

WC5758NSEKAJARIACER

WC5758NSEBERGEPAINT

WC5758NSEVEDL

WC5758NSEUPL

WC5758NSEBAJAJFINSV

WC5758NSEULTRACEMCO

WC5758NSEUJJIVAN

WC5758NSETATAGLOBAL

WC5758NSETATAELXSI

WC5758NSESTAR

WC5758NSESRTRANSFIN

WC5758NSESRF

WC5758NSESAIL

WC5758NSEHAVELLS

WC5758NSEMCDOWELL-N

WC5758NSEPEL

WC5758NSEPAGEIND

WC5758NSENMDC

WC5758NSEMOTHERSUMI

WC5758NSEMARICO

WC5758NSEM&MFIN

WC5758NSEL&TFH

WC5758NSEJUSTDIAL

WC5758NSEIGL

WC5758NSEIDFCFIRSTB

WC5758NSEIDEA

WC5758NSEIDBI

WC5758NSEHINDZINC

WC5758NSEHINDPETRO

WC5758NSEGODREJCP

WC5758NSEFEDERALBNK

WC5758NSEEXIDEIND

WC5758NSEESCORTS

WC5758NSEDISHTV

WC5758NSEDHFL

WC5758NSECUMMINSIND

WC5758NSECONCOR

WC5758NSECOLPAL

WC5758NSECESC

WC5758NSECENTURYTEX

WC5758NSECASTROLIND

WC5758NSECANBK

WC5758NSECADILAHC

WC5758NSEBIOCON

WC5758NSEBATAINDIA

WC5758NSEBANKINDIA

WC5758NSEASHOKLEY

WC5758NSEARVIND

WC5758NSEWIPRO

WC5758NSESBIN

WC5758NSEAPOLLOHOSP

WC5758NSEADANIPOWER

WC5758NSEADANIENT

WC5758NSETECHM

WC5758NSETCS

WC5758NSETATASTEEL

WC5758NSETATAPOWER

WC5758NSERELIANCE

WC5758NSEPOWERGRID

WC5758NSENTPC

WC5758NSELUPIN

WC5758NSEHINDALCO

WC5758NSELT

WC5758NSEIOC

WC5758NSEINFY

WC5758NSEICICIBANK

WC5758NSEIBULHSGFIN

WC5758NSEHEROMOTOCO

WC5758NSEHCLTECH

WC5758NSEGAIL

WC5758NSEEICHERMOT

WC5758NSEDRREDDY

WC5758NSECOALINDIA

WC5758NSEBPCL

WC5758NSEBOSCHLTD

WC5758NSEBHARTIARTL

WC5758NSEBANKBARODA

WC5758NSEBAJAJ-AUTO

WC5758NSEAUROPHARMA

WC5758NSEASIANPAINT

WC5758NSEADANIPORTS

WC5758NSEACC


Worksheet: ap-Sheet1

[DocAElstein]

Testing for this Thread Post:
http://www.excelfox.com/forum/showthread.php/2352-calculation-and-multiply-by-vba?p=11416&viewfull=1#post11416

Data Before
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXY
1UserIdAccountIdEntityNameExchg-SegSymbolInstrument NameOption TypeNetBuyValueNetSellValueNetValueNetBuyQtyNetSel lQtyNetQtyBEPSellAvgPriceBuyAvgPriceLastTradedPric eMarkToMarketRealized MarkToMarketUnrealized MarkToMarketEL MarkToMarketTrading SymbolClient ContextSeries/Expiry

2WC5758NSEMINDTREEEQ ######14760.10765.00##-5-5-5MINDTREE-EQEQ

3WC5758NSEBHELEQ ######241##67.6567.6568-0-0-0BHEL-EQEQ

4WC5758NSESIEMENSEQ ######241252.051270.20########SIEMENS-EQEQ

5WC5758NSESUNTVEQ ######24469.80472.85##-6-6-6SUNTV-EQEQ

6WC5758NSERELCAPITALEQ ######1458.1058.5057-0-0-0RELCAPITAL-EQEQ

7WC5758NSEJSWSTEELEQ ######24262.65263.60##-2-2-2JSWSTEEL-EQEQ

8WC5758NSETVSMOTOREQ ######14422.30423.10##-1-1-1TVSMOTOR-EQEQ

9WC5758NSERECLTDEQ ######14138.55140.50##-2-2-2RECLTD-EQEQ

10WC5758NSEPIDILITINDEQ ######141178.201180.00##-2-2-2PIDILITIND-EQEQ

11WC5758NSEVOLTASEQ ######14594.70595.70##-1-1-1VOLTAS-EQEQ

12WC5758NSETITANEQ ######141097.051111.00########TITAN-EQEQ

13WC5758NSEPNBEQ ######2474.5574.8574-1-1-1PNB-EQEQ

14WC5758NSEOFSSEQ ######243226.103239.95########OFSS-EQEQ

15
Worksheet: ap-Sheet1

Column Y Before ( As above )
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\ColY
1

2

3

4

5

6

7

8

9

10

11

12

13

14
Worksheet: ap-Sheet1


Column Y After running routine Sub Vixer3_For_13_data_rows()
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\ColY
1

215.3

31.353

425.404

59.457

61.17

75.272

88.462

92.81

1023.6

1111.914

1222.22

131.497

1464.799
Worksheet: ap-Sheet1

Macro version for 13 data rows

Sub Vixer3_For_13_data_rows() ' http://www.excelfox.com/forum/showthread.php/2352-calculation-and-multiply-by-vba?p=11416&viewfull=1#post11416
Rem 0 Open data workbook
' Workbooks.Open "F:\Excel0202015Jan2016\ExcelFox\vixer\Von Vixer\ap.xls"
Rem 1 Workbook and worksheets info
'Dim Wb1 As Workbook: Set Wb1 = Workbooks.Open("F:\Excel0202015Jan2016\ExcelFox\vixer\Von Vixer\ap.xls") '
Dim Wb1 As Workbook: Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\ap.xls")
Dim Ws1 As Worksheet: Set Ws1 = Wb1.Worksheets.Item(1) ' First worksheet, (as worksheet object) in open file "sample1.xlsx"
Dim Lr As Long
Let Lr = 14 ' To work with 13 data rows

Rem 3 Main Loop for all data rows
Dim Cnt As Long ' Main Loop for all data rows ================================================
' 3a)(i) ' compare column O is greater or column P is greater
For Cnt = 2 To Lr ' for 13 data rows starting at row 2
Dim Bigger As Double
If Ws1.Range("O" & Cnt & "").Value > Ws1.Range("P" & Cnt & "").Value Then ' if column O is greater
Let Bigger = Ws1.Range("O" & Cnt & "").Value
Else
Let Bigger = Ws1.Range("P" & Cnt & "").Value ' if column P is greater
End If
'3a)(ii) calculate the 0.50% of that and multiply the same with column L
Dim Rslt As Double '
Let Rslt = Bigger * (0.5 / 100) * Ws1.Range("L" & Cnt & "").Value ' calculate the 0.50% of that and multiply the same with column L
'3b) paste the result to sample1.xlsx column Y
Let Ws1.Range("Y" & Cnt & "").Value = Rslt
Next Cnt ' Main Loop for all rows ================================================== ===

Rem 4 save the changes and close the file
Wb1.Close savechanges:=True
End Sub

[DocAElstein]

In support of this Thread:
http://www.excelfox.com/forum/showthread.php/2354-Copy-amp-Paste-by-a-Vba

If column E of ap.xls matches with column A of leverage.xlsx then copy column E of leverage.xlsx and paste it to column Z of ap.xls

Before:
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
Z

1AccountIdEntityNameExchg-SegSymbol


2WC5758NSETCS


3WC5758NSESRTRANSFIN


4WC5758NSEMARICO


5WC5758NSEM&MFIN


6WC5758NSE20MICRONS


7WC5758NSECONCOR


8WC5758NSECOALINDIA


9WC5758NSEBOSCHLTD


10WC5758NSEBERGEPAINT


11WC5758NSE5PAISA


12WC5758NSETATAELXSI


13WC5758NSEHINDPETRO


14WC5758NSEDISHTV


15
Worksheet: ap-Sheet1

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

1Stock Namepro timesultimate times


220MICRONSEQINE144J01027
19
26
36.35


3TCSEQINE253B01015
19
26
13.5


43IINFOTECHEQINE748C01020
29
39
2.05


53MINDIAEQINE470A01017
48
64
21299


65PAISAEQINE618L01018
31
41
129.5


763MOONSEQINE111B01023
30
40
99.15


88KMILESEQINE650K01021
27
36
56.5


9
Worksheet: Sheet1

If column E of ap.xls matches with column A of leverage.xlsx then copy column E of leverage.xlsx and paste it to column Z of ap.xls

After
example
cell E2 of ap.xls matches with column A3 of leverage.xlsx then copy E3 of leverage.xlsx and paste it to Z2 of ap.xls


_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
Z

1AccountIdEntityNameExchg-SegSymbol


2WC5758NSETCS
25.823112


3WC5758NSESRTRANSFIN


4WC5758NSEMARICO


5WC5758NSEM&MFIN


6WC5758NSE20MICRONS
25.823112


7WC5758NSECONCOR


8WC5758NSECOALINDIA


9WC5758NSEBOSCHLTD


10WC5758NSEBERGEPAINT


11WC5758NSE5PAISA
40.795512


12WC5758NSETATAELXSI


13WC5758NSEHINDPETRO


14WC5758NSEDISHTV
Worksheet: ap-Sheet1

[DocAElstein]

For http://www.excelfox.com/forum/showthread.php/2354-Copy-amp-Paste-by-a-Vba?p=11436&viewfull=1#post11436

Before:
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
Z

1AccountIdEntityNameExchg-SegSymbol


2WC5758NSETCS


3WC5758NSESRTRANSFIN


4WC5758NSEMARICO


5WC5758NSEM&MFIN


6WC5758NSE20MICRONS


7WC5758NSECONCOR


8WC5758NSECOALINDIA


9WC5758NSEBOSCHLTD


10WC5758NSEBERGEPAINT


11WC5758NSE5PAISA


12WC5758NSETATAELXSI


13WC5758NSEHINDPETRO


14WC5758NSEDISHTV
Worksheet: ap-Sheet1

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

1Stock Namepro timesultimate times


220MICRONSEQINE144J01027
19
26
36.35


3TCSEQINE253B01015
19
26
13.5


43IINFOTECHEQINE748C01020
29
39
2.05


53MINDIAEQINE470A01017
48
64
21299


65PAISAEQINE618L01018
31
41
129.5


763MOONSEQINE111B01023
30
40
99.15


88KMILESEQINE650K01021
27
36
56.5
Worksheet: Sheet1

After:
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
Z

1AccountIdEntityNameExchg-SegSymbol


2WC5758NSETCS
25.823112


3WC5758NSESRTRANSFIN


4WC5758NSEMARICO


5WC5758NSEM&MFIN


6WC5758NSE20MICRONS
25.823112


7WC5758NSECONCOR


8WC5758NSECOALINDIA


9WC5758NSEBOSCHLTD


10WC5758NSEBERGEPAINT


11WC5758NSE5PAISA
40.795512


12WC5758NSETATAELXSI


13WC5758NSEHINDPETRO


14WC5758NSEDISHTV
Worksheet: ap-Sheet1

[DocAElstein]

In support of this Thread:
http://www.excelfox.com/forum/showthread.php/2364-Delete-row
http://www.excelfox.com/forum/showthread.php/2364-Delete-row

_____ Workbook: BasketOrder..xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQ
1NSEEQACCNANANA010BUYMARKETNACLIMISDAYWC5758NA

2NSEEQADANIPORTSNANANA010SELLMARKETNACLIMISDAYWC57 58NA

3NSEEQAMBUJACEMNANANA010BUYMARKETNACLIMISDAYWC5758 NA

4NSEEQASIANPAINTNANANA010BUYMARKETNACLIMISDAYWC575 8NA

5NSEEQAXISBANKNANANA010BUYMARKETNACLIMISDAYWC5758N A

6NSEEQBANKBARODANANANA010SELLMARKETNACLIMISDAYWC57 58NA

7
Worksheet: BasketOrder. (1)


_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEADANIPORTSEQ409409398.65407.2402

3NSEABCEQ216.2219.15215.15215.8218

4NSEASIANPAINTEQ14091441.951401.851404.21441.3

5NSEAXISBANKEQ732.9739.3728.15727.45733.65

6NSEBANKBARODAEQ118.8119.15114.7118.35115.25

7NSEBHARTIARTLEQ342.95348.5337.4342.55343.05

8
Worksheet: 1-Sheet1


The Process:
If cells of column C of basketorder.xlsx matches with cells of column B of 1.xlsx then delete the entire row of 1.xlsx(here entire row means the cells which matches delete that entire row)

_____ Workbook: BasketOrder..xlsx ( Using Excel 2007 32 bit )

NSEEQACCNANA

NSEEQADANIPORTSNANA

NSEEQAMBUJACEMNANA

NSEEQASIANPAINTNANA

NSEEQAXISBANKNANA

NSEEQBANKBARODANANA


Worksheet: BasketOrder. (1)

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )

ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

NSEADANIPORTSEQ409409398.65407.2402

NSEABCEQ216.2219.15215.15215.8218

NSEASIANPAINTEQ14091441.951401.851404.21441.3

NSEAXISBANKEQ732.9739.3728.15727.45733.65

NSEBANKBARODAEQ118.8119.15114.7118.35115.25

NSEBHARTIARTLEQ342.95348.5337.4342.55343.05


Worksheet: 1-Sheet1

[DocAElstein]

Using data from last post

Before=
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEADANIPORTSEQ
409
409
398.65
407.2
402


3NSEABCEQ
216.2
219.15
215.15
215.8
218


4NSEASIANPAINTEQ
1409
1441.95
1401.85
1404.2
1441.3


5NSEAXISBANKEQ
732.9
739.3
728.15
727.45
733.65


6NSEBANKBARODAEQ
118.8
119.15
114.7
118.35
115.25


7NSEBHARTIARTLEQ
342.95
348.5
337.4
342.55
343.05


8
Worksheet: 1-Sheet1

After=
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEABCEQ
216.2
219.15
215.15
215.8
218


3NSEBHARTIARTLEQ
342.95
348.5
337.4
342.55
343.05


4
Worksheet: 1-Sheet1




'
Sub Vixer7() ' http://www.excelfox.com/forum/showthread.php/2364-Delete-row
Rem 1 Workbook and worksheets info
'1a) Workbook info
Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook, Wb2 As Workbook ' (These will be set later when the workbooks are opened)
Dim strWb1 As String: Let strWb1 = "1.xls"
Dim strWb2 As String: Let strWb2 = "BasketOrder.xlsx" ' "BasketOrder..xlsx"
'1b) Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet ' (These will be set later when the workbooks are opened)
Dim Lr1 As Long, Lr2 As Long: Let Lr1 = 7: Lr2 = 6 ' For sample file
Rem 2 Open files ..... we have to Open all the files all files are closed except the vba placed file
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\BasketOrder. .xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb2
Set Wb2 = ActiveWorkbook '
Set Ws2 = Wb2.Worksheets.Item(1)
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\1.xls"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)
Rem 3 The Process ..."....If cells of column C of basketorder.xlsx matches with cells of column B of 1.xlsx then delete the entire row of 1.xlsx...."....
' 3a) Range.Find Method range info
' 3a)(i) Search range ( range to be searched )
Dim rngSrch As Range: Set rngSrch = Ws2.Range("C1:C" & Lr2 & "") ' .."....column C of basketorder.xlsx
' 3a)(ii)' Data range, items to be searched for
Dim rngDta As Range: Set rngDta = Ws1.Range("B2:B" & Lr1 & "") ' .."....cells of column B of 1.xlsx
' 3b) MAIN LOOP for all cells in basketorder.xlsx
Dim Cnt As Long '_====================================MAIN LOOP===========================================
For Cnt = Lr2 To 1 Step -1 ' data range to be searched for.... Important: I am going to delete rows in a loop: usually do such delete things in a backward loop. This is because I then effectively do a process on a cell or cells "behind me". So the process is done on a cell or cells no longer being considered. If I do the looping conventionally in the forward direction, then modification caused by the delete may effect the cells above, particularly their position. This can cause problems: After a delete, the cells above "move down". On the next loop I will then consider a cell above where I just was. So I will likely miss the next row to be considered, since that now occupies the position of the current loop. An alternative would be to loop forward, but after a delete to reduce the Loop count, Cnt, by 1. But changing the loop count variable in a loop is generally considered to be a bad idea https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop.html#post3929967
Dim MtchedCel As Variant ' For the range object of a matched cell if found, if not found it will be Nothing , so we must use a variant to allow for the type of Range or Nothing
Set MtchedCel = rngSrch.Find(What:=rngDta.Item(Cnt), After:=rngSrch.Item(1), LookIn:=xlValues, Lookat:=xlWhole, Searchdirection:=xlNext, MatchCase:=True) ' rngDta.Item(Cnt) will be a cell of column C of basketorder.xlsx
If Not MtchedCel Is Nothing Then ' If cell of column C of basketorder.xlsx matches with cells of column B of 1.xlsx Then .....
rngDta.Rows(Cnt).EntireRow.Delete Shift:=xlUp ' ..... delete the entire row of 1.xlsx
Else
End If

Next Cnt '_====================================MAIN LOOP============================================== =
Rem 4 ...."... after the process close and save the file so that changes should be saved
Wb1.Close savechanges:=True
End Sub

[DocAElstein]

Extra notes in support of this Thread:
http://www.excelfox.com/forum/showthread.php/2364-Delete-row
http://www.excelfox.com/forum/showthread.php/2364-Delete-row?p=11463&viewfull=1#post11463
http://www.excelfox.com/forum/showthread.php/2364-Delete-row



Making Lr dynamic ( using rng.End(XlUp) for a single column. )

For example, from http://www.excelfox.com/forum/showthread.php/2364-Delete-row :
BasketOrder.xlsx for column C, Lr is 6
( BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
)
_____ Workbook: BasketOrder.xlsx ( Using Excel 2007 32 bit )
Row\ColBCD
1EQACCNA

2EQADANIPORTSNA

3EQAMBUJACEMNA

4EQASIANPAINTNA

5EQAXISBANKNA

6EQBANKBARODANA

7
Worksheet: BasketOrder. (1)

Lr2, for column C is :
Ws2.Range("C" & Ws2.Rows.Count).End(xlUp).Row
or
Ws2.Cells.Item(Ws2.Rows.Count, 3).End(xlUp).Row
or
Ws2.Cells.Item(Ws2.Rows.Count, "C").End(xlUp).Row

To explain:
'_- 1 :- Rows.Count Property of a worksheet
Ws2.Range("C" & Ws2.Rows.Count)
or
Ws2.Cells.Item(Ws2.Rows.Count, 3)
or
Ws2.Cells.Item(Ws2.Rows.Count, "C")

For Excel 2007 and higher versions ( .xlsx .xlsm ), this is 1048576 rows in a worksheet ( ImmediateWindow RowsCount XL 2007.JPG : https://imgur.com/NHHdylV )
Ws2.Range("C" & 1048576)
or
Ws2.Cells.Item(1048576, 3)
or
Ws2.Cells.Item(1048576, "C")
This is the last cell in column C:
_____ Workbook: BasketOrder.xlsx ( Using Excel 2007 32 bit )
Row\ColBCD
1048574

1048575

1048576
Worksheet: BasketOrder. (1)

So we are at the bottom of the worksheet….

'_- 2 :- .End(xlUp) Property action
This is the same as keyboard keys _ Ctrl+UpArrow
Ctrl + UpArrow.JPG : https://imgur.com/w5w8KxZ

….This action will take you back up to the next filled cell:
_End(XlUp).JPG : https://imgur.com/JQJxc1s

….So we are at the last filled cell in column C

'_- 3 :- .Row Property
This will give you the row number of the cell
_Row.JPG : https://imgur.com/bMpaBOv



For example, from http://www.excelfox.com/forum/showthread.php/2364-Delete-row :
1.xls for column B, Lr is 7
( 1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e )
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\ColABC
1ExchangeSymbolSeries/Expiry

2NSEADANIPORTSEQ

3NSEABCEQ

4NSEASIANPAINTEQ

5NSEAXISBANKEQ

6NSEBANKBARODAEQ

7NSEBHARTIARTLEQ

8
Worksheet: 1-Sheet1

Lr1, for column B is :
Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
or
Ws1.Cells.Item(Ws1.Rows.Count, 2).End(xlUp).Row
or
Ws1.Cells.Item(Ws1.Rows.Count, "B").End(xlUp).Row

To explain:
'_- 1 :- Rows.Count Property of a worksheet
Ws1.Range("B" & Ws1.Rows.Count)
or
Ws1.Cells.Item(Ws1.Rows.Count, 2)
or
Ws1.Cells.Item(Ws1.Rows.Count, "B")

For Excel 97 - 2003 ( .xls ), this is 65536 rows in a worksheet ( ImmediateWindow RowsCount XL 2003.JPG : https://imgur.com/iOmrf9n )
Ws1.Range("B" & 65536 ))
or
Ws1.Cells.Item( 65536 , 2)
or
Ws1.Cells.Item( 65536 , "B")

This is the last cell in column B:
(Last Worksheet Row in XL 2003.JPG : https://imgur.com/iaEPoZG )
2401
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\ColABC
65533

65534

65535

65536
Worksheet: 1-Sheet1

So we are at the bottom of the worksheet …

'_- 2 :- .End(xlUp) Property action
This is the same as keyboard keys _ Ctrl+UpArrow
Ctrl + UpArrow.JPG : https://imgur.com/w5w8KxZ
2402

…This action will take you back up to the next filled cell:
_End(XlUp) XL2003.JPG : https://imgur.com/JYPd95V
2403

….So we are at the last filled cell in column B

'_- 3 :- .Row Property
This will give you the row number of the cell
_ Row.JPG : https://imgur.com/ZWCFvmr
2404




Example Demo
For uploaded files..
BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e
run this macro

Sub Vixer8_MakingLrDynamic() ' http://www.excelfox.com/forum/showthread.php/2364-Delete-row?p=11463&viewfull=1#post11463
'
Rem 1 Workbook and worksheets info
'1a) Workbook info
Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook, Wb2 As Workbook ' (These will be set later when the workbooks are opened)
Dim strWb1 As String: Let strWb1 = "1.xls" ' --- 1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e
Dim strWb2 As String: Let strWb2 = "BasketOrder.xlsx" ' "BasketOrder..xlsx" --- BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
'1b) Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet ' (These will be set later when the workbooks are opened)
' Dim Lr1 As Long, Lr2 As Long ' To be determined from files : Let Lr1 = 7: Lr2 = 6 ' For sample files
Rem 2 Open files ..... we have to Open all the files all files are closed except the vba placed file
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\BasketOrder. .xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb2
Set Wb2 = ActiveWorkbook '
Set Ws2 = Wb2.Worksheets.Item(1)
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\1.xls"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)



Rem 3 making Lr dynamic
Dim Lr2 As Long
Let Lr2 = Ws2.Range("C" & Ws2.Rows.Count).End(xlUp).Row
Let Lr2 = Ws2.Cells.Item(Ws2.Rows.Count, 3).End(xlUp).Row
Let Lr2 = Ws2.Cells.Item(Ws2.Rows.Count, "C").End(xlUp).Row
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, 2).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, "B").End(xlUp).Row

'3b) demo
Ws2.Activate
MsgBox prompt:="Lr in worksheet " & Ws2.Name & ", in workbook " & Wb2.Name & " is " & Lr2 & vbCrLf & "(last row in worksheet is " & Ws2.Rows.Count & ")"
Ws1.Activate
MsgBox prompt:="Lr in worksheet " & Ws1.Name & ", in workbook " & Wb1.Name & " is " & Lr1 & vbCrLf & "(last row in worksheet is " & Ws1.Rows.Count & ")"

Rem 4 close files
Wb2.Close: Wb1.Close
End Sub








Ref:
https://www.excelforum.com/hello-introduce-yourself/1214555-an-old-geezer-coming-over-from-the-access-forum.html
http://www.excelfox.com/forum/showthread.php/2157-Re-Defining-multiple-variables-in-VBA?p=10192&viewfull=1#post10192
http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466#post11466










BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e

[DocAElstein]

in support of this Thread:
http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba?p=11472#post11472
https://www.mrexcel.com/forum/excel-questions/1109256-add-calculation-vba.html
http://www.vbaexpress.com/forum/showthread.php?65832-Formula-by-vba
www.excelforum.com/excel-programming-vba-macros/1289175-add-a-calculation-by-vba.html




_____ Workbook: 124.xlsb ( Using Excel 2007 32 bit )
Row\ColABCDEF
1SymbolLTP1st row contains headers so ignore the first row

2ACC1587.95501333.878Column D is the result that I need by vba

3ADANIPORTS40270337.68I don't want formulas I need only the result in column D

4AMBUJACEM21820183.12

5ASIANPAINT1441.3101210.692

6AXISBANK733.655616.266

7BANKBARODA115.25796.81

8BHARTIARTL343.058288.162

9BOSCHLTD151501912726

10BPCL359350301.56

11

12Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2

131333.878

14
Worksheet: Sheet1

_____ Workbook: sample.xlsx ( Using Excel 2007 32 bit )
Row\Col
E

12Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2


13
=B2*(1.5/100)*56
Worksheet: Sheet1



Before
_____ Workbook: 124.xlsb ( Using Excel 2007 32 bit )
Row\ColABCD
2ACC1587.9550

3ADANIPORTS40270

4AMBUJACEM21820

5ASIANPAINT1441.310

6AXISBANK733.655

7BANKBARODA115.257

8BHARTIARTL343.058

9BOSCHLTD1515019

10BPCL359350
Worksheet: Sheet1

After
_____ Workbook: 124.xlsb ( Using Excel 2007 32 bit )
Row\ColABCD
2ACC1587.95501333.878

3ADANIPORTS40270337.68

4AMBUJACEM21820183.12

5ASIANPAINT1441.3101210.692

6AXISBANK733.655616.266

7BANKBARODA115.25796.81

8BHARTIARTL343.058288.162

9BOSCHLTD151501912726

10BPCL359350301.56
Worksheet: Sheet1

[DocAElstein]

In support of this Thread:
http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba?p=11472&viewfull=1#post11472
http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba?p=11472&viewfull=1#post11472



i have data upto 100 or 200 rows it can be more all it depends i have to do the same process till the end of the data
So we need to make Lr dynamic, for example
sample.xlsx
_____ Workbook: sample.xlsx ( Using Excel 2007 32 bit )
Row\ColABCD
1SymbolLTP

2ACC1587.9550

3ADANIPORTS40270

4AMBUJACEM21820

5ASIANPAINT1441.310

6AXISBANK733.655

7BANKBARODA115.257

8BHARTIARTL343.058

9BOSCHLTD1515019

10BPCL359350

11
Worksheet: Sheet1




'
Sub Vixer8b_MakingLrDynamic() ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11474&viewfull=1#post11474
'
Rem 1 Workbook and worksheets info
'1a) Workbook info
Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook ' (This will be set later when the workbooks are opened)
Dim strWb1 As String: Let strWb1 = "sample.xlsx"
'1b) Worksheets info
Dim Ws1 As Worksheet ' (This will be set later when the workbooks are opened)
' Dim Lr1 As Long, Lr2 As Long ' To be determined from files : Let Lr1 = 7: Lr2 = 6 ' For sample files
Rem 2 Open file .....
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)



Rem 3 making Lr dynamic
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, 3).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, "C").End(xlUp).Row

'3b)(i) demo (i)
Ws1.Activate
MsgBox prompt:="Lr in worksheet " & Ws1.Name & ", in workbook " & Wb1.Name & " is " & Lr1 & vbCrLf & "(last row in worksheet is " & Ws1.Rows.Count & ")"

'3b)(ii) demo (ii)
Ws1.Range("C" & Ws1.Rows.Count).Select ' select last cell in column C
Application.Wait (Now + TimeValue("0:00:03")) ' VBA wait 3 seconds https://docs.microsoft.com/de-de/office/vba/api/excel.application.wait

ActiveCell.End(xlUp).Select ' go back up to last used cell in column C
Application.Wait (Now + TimeValue("0:00:06")) ' VBA wait 6 seconds

Rem 4 close file
Wb1.Close
End Sub



Rem 3 making Lr dynamic
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, 3).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, "C").End(xlUp).Row



To explain:-

_ Rows.Count
Ws1.Range("C" & Ws1.Rows.Count)
Or
Ws1.Cells.Item(Ws1.Rows.Count, 3)
Or
Ws1.Cells.Item(Ws1.Rows.Count, "C")

We are in a .xlsx file, so Rows.Count is 1048576
Ws1.Range("C" & 1048576)
or
Ws1.Cells.Item(1048576, 3)
or
Ws1.Cells.Item(1048576, "C")

This is the last cell in column C:
Last cell in Column C in worksheet Sheet1 in workbook sample xlsx.JPG : https://imgur.com/HH9UKki
2413
_____ Workbook: sample.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1048574


1048575


1048576
Worksheet: Sheet1

So we are at the bottom of the worksheet…..

_ .End(XlUp) Property action
This is the same as keyboard keys _ Ctrl+UpArrow
Ctrl + UpArrow.JPG : https://imgur.com/w5w8KxZ
2402

…This action will take you back up to the next filled cell:
_End(XlUp) in column C from last cell in worksheet Sheet1 in workbook sample xlsx : https://imgur.com/fIDDbYB
2411

…so we are at the last cell in column C that is filled with something

_ .Row Property
This will return the row number or the cell to which it is applied.
_Row for current active cell.JPG : https://imgur.com/uKVAIgN
2412

[DocAElstein]

Some further notes and information for this Thread:
http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba?p=11476#post11476
http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba
https://www.mrexcel.com/forum/excel-questions/1109256-add-calculation-vba.html
http://www.vbaexpress.com/forum/showthread.php?65832-Formula-by-vba
https://www.excelforum.com/excel-programming-vba-macros/1289175-add-a-calculation-by-vba.html


There are many different was to achieve the same…
Some further notes on changes that can be made to Sub Vixer9a() from here: http://www.excelfox.com/forum/showthread.php/2369-Calculation-by-vba?p=11475&viewfull=1#post11475



b) Rng.Value = Rng.Value

Excel VBA has been written such that applying .Value to a cell or cells has a similar effect to writing manually into a cell.

So if you do this:
Range("A1").Value = "X"
, it will write
X
in the first cell.
You will then see in the first cell this
X

If you do this:
Range("A1").Value = " = 1"
, it will write
= 1
in the first cell.
But, you will see in the first cell just the Value:
1

To explain:
The .Value Property of a range object , for example a single cell, is what we "see" in the cell. But if you apply .Value to a cell it will write into the cell as if you did it manually.

So, in your code you can replace this: …_

'3(iii) I need only result in the cell no formulas
Ws1.Range("D2:D" & Lr1 & "").Copy
Ws1.Range("D2:D" & Lr1 & "").PasteSpecial Paste:=xlPasteValues
Let Application.CutCopyMode = False

_.. with this:

'3(iii) I need only result in the cell no formulas
Let Ws1.Range("D2:D" & Lr1 & "").Value = Ws1.Range("D2:D" & Lr1 & "").Value



Sub Vixer9b() ' demo for rng.Value = rng.Value
Rem 1 Workbook and worksheets info
'1a) Workbook info
' Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook ' This will be set later when the workbook is opened
Dim MyPath As String: Let MyPath = "C:\Users\sk\Desktop" ' ".....The file will be located in C:\Users\sk\Desktop ....
Dim strWb1 As String: Let strWb1 = "sample.xlsx" ' " ....and file name is sample.xlsx
'1b) Worksheets info
Dim Ws1 As Worksheet ' This will be set later when the workbook is opened)
Dim Lr1 As Long ' Let Lr1 = 10 for sample file , but we will determine it dynamically after opening the file
Rem 2 Open file "..... file is not opened so we have to open the file by vba
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\sample.xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1 ' ...both files are located in same place
' Workbooks.Open Filename:=MyPath & "\" & strWb1 ' ...file will be located in C:\Users\sk\Desktop
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)

' make Lr1 dynamic .... http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11474&viewfull=1#post11474
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Rem 3 The Process ..."....
'3(i) ....Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2.. formula will be added by me in the code, put that formula in
Ws1.Range("D2").Value = "=B2*(1.5/100)*56"
'3(ii) ....drag it
Ws1.Range("D2").AutoFill Destination:=Ws1.Range("D2:D" & Lr1 & ""), Type:=xlFillDefault
'3(iii) I need only result in the cell no formulas
Let Ws1.Range("D2:D" & Lr1 & "").Value = Ws1.Range("D2:D" & Lr1 & "").Value
Rem 4 save it and close it
Wb1.Save
Wb1.Close
End Sub





_c) Apply "fixed vector"** form across a range

I can apply the formula in its "fixed vector"** form across a range. In other words I can apply the same formula in its fixed vector form across a range. Applying the same fixed vector formula across a range will make any referred to cells change the shown formula appropriately to apply to the different cells

** In simplified terms, "fixed vector", means notation without the $. So..
A1 is "fixed vector"
$A$1 is absolute referencing

So we can replace this:


'3(i) ....Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2.. formula will be added by me in the code, put that formula in
Ws1.Range("D2").Value = "=B2*(1.5/100)*56"
'3(ii) ....drag it
Ws1.Range("D2").AutoFill Destination:=Ws1.Range("D2:D" & Lr1 & ""), Type:=xlFillDefault
With this:

'3(i)(ii) ....Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2.. ....drag it formula will be added by me in the code, put that formula in
Ws1.Range("D2:D" & Lr1 & "").Value = "=B2*(1.5/100)*56"


Sub Vixer9c() ' demo for fixed vector applied across a range
Rem 1 Workbook and worksheets info
'1a) Workbook info
' Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook ' This will be set later when the workbook is opened
Dim MyPath As String: Let MyPath = "C:\Users\sk\Desktop" ' ".....The file will be located in C:\Users\sk\Desktop ....
Dim strWb1 As String: Let strWb1 = "sample.xlsx" ' " ....and file name is sample.xlsx
'1b) Worksheets info
Dim Ws1 As Worksheet ' This will be set later when the workbook is opened)
Dim Lr1 As Long ' Let Lr1 = 10 for sample file , but we will determine it dynamically after opening the file
Rem 2 Open file "..... file is not opened so we have to open the file by vba
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\sample.xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1 ' ...both files are located in same place
' Workbooks.Open Filename:=MyPath & "\" & strWb1 ' ...file will be located in C:\Users\sk\Desktop
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)

' make Lr1 dynamic .... http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11474&viewfull=1#post11474
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Rem 3 The Process ..."....
'3(i)(ii) ....Multiply the value of B2 by 1.5%, then multiply that result by 56 and then paste the result in D2.. ....drag it formula will be added by me in the code, put that formula in
Ws1.Range("D2:D" & Lr1 & "").Value = "=B2*(1.5/100)*56"
'3(iii) I need only result in the cell no formulas
Let Ws1.Range("D2:D" & Lr1 & "").Value = Ws1.Range("D2:D" & Lr1 & "").Value
Rem 4 save it and close it
Wb1.Save
Wb1.Close
End Sub





_d) Internal calculation with VBA arrays
We do not need to put formulas into any cells.
We can do the calculations internally, within coding, and then paste all the values out in one go.
Using VBA arrays is a convenient way to do this.

_a) First we bring all the data into an array.
_b) Then we do the calculations
_c) Finally we paste out all the calculated values in one go

We can replace all of Rem3 with new coding
Rem 3 The Process .. using VBA arrays
'3_a) First we bring all the data into an array.
'3_b) Now we do the calculations
'3_c) Finally we paste out all the calculated values in one go

Rem 3 The Process ...using VBA arrays
'3_a) First we bring all the data into an array. (We also take in the column D values, even if the column D is empty)
Dim arrDta() As Variant
Let arrDta() = Ws1.Range("A1:D" & Lr1 & "").Value
'3_b) Now we do the calculations looping through the row data held internally in the data array, arrDta()
Dim Cnt As Long
For Cnt = 2 To Lr1
Let arrDta(Cnt, 4) = arrDta(Cnt, 2) * (1.5 / 100) * 56 ' .. like.. column "D" = column "B" * (1.5/100) * 56
Next Cnt
'3_c) Finally we paste out all the calculated values ( and also the original data ) in one go
Ws1.Range("A1:D" & Lr1 & "").Value = arrDta()

Sub Vixer9d() ' demo using VBA arrays
Rem 1 Workbook and worksheets info
'1a) Workbook info
' Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook ' This will be set later when the workbook is opened
Dim MyPath As String: Let MyPath = "C:\Users\sk\Desktop" ' ".....The file will be located in C:\Users\sk\Desktop ....
Dim strWb1 As String: Let strWb1 = "sample.xlsx" ' " ....and file name is sample.xlsx
'1b) Worksheets info
Dim Ws1 As Worksheet ' This will be set later when the workbook is opened)
Dim Lr1 As Long ' Let Lr1 = 10 for sample file , but we will determine it dynamically after opening the file
Rem 2 Open file "..... file is not opened so we have to open the file by vba
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\sample.xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1 ' ...both files are located in same place
' Workbooks.Open Filename:=MyPath & "\" & strWb1 ' ...file will be located in C:\Users\sk\Desktop
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)

' make Lr1 dynamic .... http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11474&viewfull=1#post11474
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Rem 3 The Process ...using VBA arrays
'3_a) First we bring all the data into an array. (We also take in the column D values, even if the column D is empty)
Dim arrDta() As Variant
Let arrDta() = Ws1.Range("A1:D" & Lr1 & "").Value
'3_b) Now we do the calculations looping through the row data held internally in the data array, arrDta()
Dim Cnt As Long
For Cnt = 2 To Lr1
Let arrDta(Cnt, 4) = arrDta(Cnt, 2) * (1.5 / 100) * 56 ' .. like.. column "D" = column "B" * (1.5/100) * 56
Next Cnt
'3_c) Finally we paste out all the calculated values ( and also the original data ) in one go
Ws1.Range("A1:D" & Lr1 & "").Value = arrDta()
Rem 4 save it and close it
Wb1.Save
Wb1.Close
End Sub




_e) Evaluate Range
see next post:

[DocAElstein]

_e) Evaluate Range

It is possible to get array type calculations in Excel. Nobody fully understands this topic, and a lot of things are found by chance to work in a way such as to do array type calculations, or rather , array type results can be obtained.

Evaluate Range techniques often allow a looping process to be replaced ba a single line of code. Broadly this arises due to two things:
_1) Excel frequently updates all cells in a spreadsheet by going across the columns in a row , then down a row, then across the columns in the next row … etc.
Usually a user "using" a single cell is like when it selected, and/ or the carriage Return key is used, and so it appears to us as if the cell is Updated and displayed at one time. There are various ways to display more than one cell in a single spreadsheet update.
_2) In VBA there is an Evaluate Method ( https://docs.microsoft.com/en-us/office/vba/api/excel.application.evaluate ). In simplified terms, this allows calculation within VBA as if the calculations were written and done in a spreadsheet.

It is possible sometimes to get the Evaluate function to return an array representing the calculations across a range
There is no clear documentation on any of the array type things discussed in this post, and it is often suggested that getting array results in any form in Excel has occurred by chance and no one understands fully what is going on.


As an example, considering the last macro which looped to produce an array based on doing these calculations of this form, from down rows of 2 to Lr1
B2*(1.5/100)*56
B3*(1.5/100)*56
B4*(1.5/100)*56
_…. etc.

We find that Rem 3 from the last macro, Sub Vixer9d() , can be replaced by

Rem 3 The Process ... using Evaluate Range
Ws1.Range("D2:D" & Lr1 & "").Value = Ws1.Evaluate("=" & Range("B2:B" & Lr1 & "").Address & "*(1.5/100)*56")


The purpose of ("=" & Range("B2:B" & Lr1 & "") is to give us the formula form of like
=B2:B10
Hence the Range used does not need to be Qualified, such as by a worksheet, like in Ws1.Range
( There is an alternative form of Evaluate(" __ ") , which is often referred to as the "shorthand form" of Evaluate(" __ ") . It looks like this _ [ ___ ] _ . So you may now see what Mark L was suggesting here: https://www.excelforum.com/excel-programming-vba-macros/1289175-add-a-calculation-by-vba.html#post5190685 )

It is , however , important to qualify Evaluate. this is because we want to do an evaluation as if the formula within Evaluate(" ___ ") , was in the cell in worksheet, Ws1. If we omit the qualifying _ Ws1. _ , before the Evaluate , then we may do an evaluation of the formula in a different worksheet.



Sub Vixer9e() ' demo for Evaluate Range
Rem 1 Workbook and worksheets info
'1a) Workbook info
' Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook ' This will be set later when the workbook is opened
Dim MyPath As String: Let MyPath = "C:\Users\sk\Desktop" ' ".....The file will be located in C:\Users\sk\Desktop ....
Dim strWb1 As String: Let strWb1 = "sample.xlsx" ' " ....and file name is sample.xlsx
'1b) Worksheets info
Dim Ws1 As Worksheet ' This will be set later when the workbook is opened)
Dim Lr1 As Long ' Let Lr1 = 10 for sample file , but we will determine it dynamically after opening the file
Rem 2 Open file "..... file is not opened so we have to open the file by vba
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\sample.xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1 ' ...both files are located in same place
' Workbooks.Open Filename:=MyPath & "\" & strWb1 ' ...file will be located in C:\Users\sk\Desktop
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)

' make Lr1 dynamic .... http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11474&viewfull=1#post11474
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count).End(xlUp).Row
Rem 3 The Process ... using Evaluate Range
Ws1.Range("D2:D" & Lr1 & "").Value = Ws1.Evaluate("=" & Range("B2:B" & Lr1 & "").Address & "*(1.5/100)*56")
Rem 4 save it and close it
Wb1.Save
Wb1.Close
End Sub






Using Evaluate often results in a much shorter coding.

For example, taking Sub Vixer9e() , and making a few other simplifications we can come up with a much shorter coding.



Sub Vixer9f() ' simplified coding ( using Range Evaluate )
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "sample.xlsx" ' ...both files are located in same place
Rem 3 The Process ... using Evaluate Range
ActiveSheet.Range("D2:D" & ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row & "").Value = ActiveSheet.Evaluate("=" & Range("B2:B" & ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row & "").Address & "*(1.5/100)*56")
Rem 4 save it and close it
ActiveWorkbook.Close savechanges:=True
End Sub






I personally do not like such coding because
_(i) They are more difficult to understand, especially at a later date,
_(ii) They are less flexible for adjustment.
_(iii) There may be some missing detail which might cause the coding to fail sometimes in certain circumstances

[DocAElstein]

in support of this post:
https://excel.tips.net/T001940_Hiding_Rows_Based_on_a_Cell_Value.html
https://excel.tips.net/T001940_Hiding_Rows_Based_on_a_Cell_Value.html


Hello Ryanne
Rather than modifying the coding, it would probably be easier to use a simple "events" type coding which automatically kicks in when a range value is changed in a worksheet. Something of this form:.


Private Sub Worksheet_Change(ByVal Target As Range)
Target.EntireRow.Hidden = True
End Sub


































'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
'End Sub

This coding will need to be in a worksheet code module.
Follow , for example these 6 steps to create such a coding:

_1) Right click on the tab of the worksheet of interest
_2) Select View Code
Worksheet code module via View Code after right click on tab.JPG : : https://imgur.com/ZiOuRVT
2426

_3) Select the left side drop down list
_4) Select Worksheet
Worksheet.JPG : https://imgur.com/tCwHKBo
2427

_5) Select the right drop down list
_6) Select Change
Change.JPG : https://imgur.com/NkbNPsL
2428

( Delete or ' comment out any other coding, such as the Private Sub Worksheet_SelectionChange which may have appeared automatically at step 4 )



You can now add your coding within the Private Sub Worksheet_Change


( Hit Alt+F11 to return to spreadsheet view )

The coding will kick off automatically when you change any cell value. It will hide the entire row which contains the cell whose value you changed


In the uploaded file , I have added the coding to the third worksheet code module

Alan



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Some supporting notes for some other stuff...



_3) Regarding the remaining leftover hide.me app on Windows 7 machine after I de- installed it
….( hide.me that was still showing in my program list after I had de installed, and note also that on restarting the windows 7 machine with the remaining left over hideme app, a hideme typically window came up , did something for a while, then another hide me window came up and offered me the chance to buy premium!! )
Strange remaining hide me thing after de install.JPG : https://imgur.com/4HsLmDN
2439

I tried the Revo Unistaller as suggested, http://revo-uninstaller.en.softonic.com/ .
This was also not able to de install the hide.me that was still showing in my program list after I had de installed it: Revo also cannot de install the remaining hide.me.jpghttps://imgur.com/HY7pSIy
After this failed attempt, I performed the scan that Revo offered.
This scan took several hours. The scan first showed these left over registry things, Revo scan found left over hideme.jpg : https://imgur.com/r99WKN6
2440
, which I chose to delete: Choose to delete found left over hideme.jpg , Deleting scan found left over hideme.jpg : https://imgur.com/aoToZJ2 , https://imgur.com/5jsACjQ .
Then the following left over files and folders were also shown, Revo scan found left over hideme Files and Folders.jpg : https://imgur.com/78YKmd4
2441
, which I also chose to delete: Choose to delete Revo scan found left over hideme Files and Folders.jpg , Deletingf Revo scan found left over hideme Files and Folders.jpg : https://imgur.com/VAlBzED , https://imgur.com/2YoSSML .
Finally it appears that all left over hide.me files are gone: hideme no longer listed in programs.jpg : https://imgur.com/9aentWL
A restart is said to remove some files, .. Revo says remainig files will be deleted by restart.jpg : https://imgur.com/QTjDtf1 , so I restarted.
It seemed at this stage, ( after a restart) that the hideme app was completely removed.

[DocAElstein]

In support of answers to these Threads:
http://www.excelfox.com/forum/showthread.php/2378-Mail-the-files-by-vba-to-a-specified-email-id
https://stackoverflow.com/questions/58525487/excel-vba-cdo-message-email-sending-accounts-work-less-and-less?noredirect=1#comment103375857_58525487
https://stackoverflow.com/questions/58286932/cdo-gmail-macro-some-accounts-work-some-don-t-message-could-not-be-sent-to-sm
https://stackoverflow.com/questions/58525487/excel-vba-cdo-message-email-sending-accounts-work-less-and-less







Register an account with Freemail German Telekom, for use with CDO.Message Send program
Login / Register
https://www.t-online.de/
Login.JPG : https://imgur.com/n5aLakd
https://accounts.login.idm.telekom.com/oauth2/auth?client_id=10LIVESAM30000004901PORTAL000000000 00000&state=d725154dc1fc296807eda1341546636892fc9739ccb7 5d714dc2c89b4159148e&claims=%7B%22id_token%22%3A%7B%22urn%3Atelekom.com %3Aall%22%3Anull%7D%7D&nonce=d725154dc1fc296807eda1341546636892fc9739ccb7 5d714dc2c89b4159148e&redirect_uri=https%3A%2F%2Flogin.t-online.de%2Fcallback&display=popup&scope=openid&response_type=code#
https://accounts.login.idm.telekom.com/oauth2/auth?client_id=10LIVESAM30000004901PORTAL000000000 00000&state=d725154dc1fc296807eda1341546636892fc9739ccb7 5d714dc2c89b4159148e&claims=%7B%22id_token%22%3A%7B%22urn%3Atelekom.com %3Aall%22%3Anull%7D%7D&nonce=d725154dc1fc296807eda1341546636892fc9739ccb7 5d714dc2c89b4159148e&redirect_uri=https%3A%2F%2Flogin.t-online.de%2Fcallback&display=popup&scope=openid&response_type=code#
Registrieren.JPG : https://imgur.com/J6nnDm2
https://meinkonto.telekom-dienste.de/telekom/account/registration/assistant/index.xhtml
https://meinkonto.telekom-dienste.de/telekom/account/registration/assistant/userstatus.xhtml
UserStatus.jpg : https://imgur.com/IqjhWop

New Email Address
New Email Address.jpg : https://imgur.com/zH2G73c

Register
Register.JPG : https://imgur.com/570UkbH
https://imgur.com/D6vRwex
You will probably be sent a number code via SMS to your Telephine number. , https://imgur.com/eBpabq5 ,



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In support to answer of this Thread:
http://www.excelfox.com/forum/showthread.php/2383-compare-data?p=11557&viewfull=1#post11557

_____ Workbook: VBA.xls ( Using Excel 2007 32 bit )
Row\Col
A

1
1234


2
5678


3
91011


4
12131415


5
1617181920
Worksheet: abc
'match column A of abc sheet with column A of def sheet
' if it matches then delete that data in column A of def
' "match column A of abc sheet with column A of def sheet if it matches then delete that data in column A of def"

_____ Workbook: VBA.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1
1234


2
15678


3
191011


4
112131415


5
16171811920after the process completed delete all the data in this sheet
Worksheet: def
_____ Workbook: VBA Exampled.xls ( Using Excel 2007 32 bit )


15678


191011


112131415


16171811920
Worksheet: def
_____ Workbook: VBA Exampled.xls ( Using Excel 2007 32 bit )



'and the data which are not matched compare that data ( here 'that data' means unmatched data in abc. Right? ) with Fake Data and
' if matched then delete and again if there will be unmatched data ( here also 'unmatched data' means unmatched data in abc. Right? ) then
_____ Workbook: VBA.xls ( Using Excel 2007 32 bit )
Row\Col
A

1
115678


2
191011


3
1112131415


4
1.16172E+11
Worksheet: Fake Data
_____ Workbook: VBA Exampled.xls ( Using Excel 2007 32 bit )



15678


112131415


16171811920
Worksheet: def


115678


1112131415


1.16172E+11
Worksheet: Fake Data



'................................................. ...................if there will be unmatched data then
' compare that data with complete data
_____ Workbook: VBA.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
115678


2
Worksheet: Completed
' if found then delete and again if there will be unmatched data


1112131415


1.16172E+11
Worksheet: Fake Data
then
' copy that data and paste it to missing data sheet in column A ( and finally delete all the data in def : after the process completed delete all the data in this sheet )


the final result is in missing data sheet plz see
missing data sheet already has data and we have pasted the result below that data(the data starts with A2 is the result)
A1 in missing data sheet already has data so we putted the result below that plz see sir
....in simple words with def sheet the data which are present in column A doesnt match with any sheet column A data then put that data in missing data sheet sir (sheet can be many)

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

1
11111158


2
1112131415


3
1.16172E+11


4
Worksheet: Missing data
_____ Workbook: VBA Exampled.xls ( Using Excel 2007 32 bit )


11111158


1112131415


1.16172E+11
Worksheet: Missing data

[DocAElstein]

follow on from last post:

Before

the final result is in missing data sheet plz see
missing data sheet already has data and we have pasted the result below that data(the data starts with A2 is the result)
A1 in missing data sheet already has data so we putted the result below that plz see sir
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
11111158


2


3


4
Worksheet: Missing data
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
1234


2
5678


3
91011


4
12131415


5
1617181920


6
Worksheet: abc
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1
1234


2
15678


3
191011


4
112131415


5
16171811920after the process completed delete all the data in this sheet
Worksheet: def
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
115678


2
191011


3
1112131415


4
1.16172E+11


5
Worksheet: Fake Data
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
115678


2
Worksheet: Completed
_____ Workbook: VBA Before.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
11111158


2


3


4
Worksheet: Missing data

[DocAElstein]

Follow on from last 2 posts





Explanation attempt
Column A of worksheet abc is compared with column A of worksheet def, looking for matches in data. If data in Column A of worksheet def is also found in column A of worksheet abc, then that matched data in column A of worksheet def is deleted
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
1234


2
5678


3
91011


4
12131415


5
1617181920


6
Worksheet: abc
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A

1
1234


2
15678


3
191011


4
112131415


5
16171811920
Worksheet: def
Column A of worksheet abc is compared with column A of worksheet def, looking for matches in data. If data in Column A of worksheet def is also found in column A of worksheet abc, then that matched data in column A of worksheet def is deleted
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )


1234


15678


191011


112131415


16171811920
Worksheet: def (modified)


The remain data in worksheet def is now compared with column A of worksheet Fake Data.
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
115678


2
191011


3
1112131415


4
1.16172E+11


5
Worksheet: Fake Data
If data in Column A of worksheet Fake Data is also found in column A of the modified worksheet def, then that matched data in column A of worksheet Fake Data is deleted
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )


115678


191011


1112131415


1.16172E+11
Worksheet: Fake Data (modified)

The remaining data in column A of modified worksheet Fake Data is now compared with column A of worksheet Completed
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
115678


2
Worksheet: Completed
If there is a match in data in columns A of worksheet Completed, and column A of worksheet Fake Data, then delete that matched data from worksheet Fake Data
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )


115678


191011


1112131415


1.16172E+11
Worksheet: Fake Data (modified)

If there is now any remaining data in column A of modified Fake Data, then that data is added to column A of missing data , ( in the given example, VBA Before.xls , A1 in missing data sheet already had data
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A

1
11111158


2
Worksheet: Missing data
so we put the result below that:
_____ Workbook: VBA worked excample.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1
11111158


2
1112131415


3
1.16172E+11


4
Worksheet: Missing data (final)

[DocAElstein]

Coding for this Thread
http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11794&viewfull=1#post11794



Sub MakeFormulas3() ' http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11794&viewfull=1#post11794
Rem 1 ' Workbooks info
' 1a This months book, this workbook. It is the outout book for the current month
Dim ThisMonthsLatestBook As Workbook, LisWbName As String
Set ThisMonthsLatestBook = ThisWorkbook ' ActiveWorkbook
Let LisWbName = ThisMonthsLatestBook.Name
If InStr(7, LisWbName, Format(Now(), "MMM"), vbTextCompare) = 0 Then MsgBox Prompt:="This workbook is not for " & Format(Now(), "MMMM"): Exit Sub
Dim BookN As Long
Let BookN = Mid(LisWbName, 5, InStr(5, LisWbName, "_", vbBinaryCompare) - 5)
' 1b Last months book
Dim sourceBookName As String
Let sourceBookName = "Book" & BookN - 1 & "_" & Format(DateAdd("m", -1, Now()), "MMM YYYY") & ".xlsm"
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & sourceBookName)
Rem 2 Make records worksheet Sub MakeWorkSheetIfNotThere()
'Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" 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 Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
' Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: 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 '
If Not Evaluate("=ISREF(" & "'" & "Records" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "My Records"
ThisMonthsLatestBook.Worksheets.Add After:=ThisMonthsLatestBook.Worksheets.Item(Worksh eets.Count) 'A sheeet is added and will be Active
Dim wsRcds As Worksheet '
Set wsRcds = ThisMonthsLatestBook.Worksheets.Item(ThisMonthsLat estBook.Worksheets.Count) 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: 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 ' 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
wsRcds.Activate: wsRcds.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let wsRcds.Name = "Records"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set wsRcds = ThisWorkbook.Worksheets("Records")
End If
' End Sub
Rem 3 looping through worksheets
Dim C As Long, I As Long
'C = ActiveWorkbook.Worksheets.Count
'Let C = ThisWorkbook.Worksheets.Count
Let C = ThisMonthsLatestBook.Worksheets.Count - 1 ' -1 since last worksheet is records worksheet
'For I = 1 To C
'Application.ScreenUpdating = True
For I = 1 To C ' Sheet1 , Sheet2 , Sheet3 .......
'what are our worksheets? I = 1 , 2 , 3 ..........
Dim sourceSheet As Worksheet
Set sourceSheet = sourceBook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........

'Determine last row of source
With sourceSheet
Dim SourceLastRow As Long
SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With outputSheet
'Determine last row in col P
Dim OutputLastRow As Long
OutputLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
End With
'Apply our formula in records worksheet
With Worksheets("Records")
Let .Cells.Item(1, I).Value = sourceSheet.Name ' Header in column as worksheet name
'.Range("Q2:Q" & OutputLastRow).Formula = "=VLOOKUP($A2,'[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
.Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = "=VLOOKUP(" & outputSheet.Name & "!$A2,'" & sourceBook.Path & "\" & "[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
' .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value
End With
'MsgBox ActiveWorkbook.Worksheets(I).Name
MsgBox ActiveWorkbook.Worksheets.Item(I).Name
Next I
'Next P
Rem 4
Dim cel As Range
With Worksheets("Records").UsedRange
For Each cel In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If IsError(cel.Value) Then
'
Else
If cel.Value < 3 Then
cel.Font.Color = vbRed
Else
cel.Font.Color = vbGreen
End If
End If
Next cel
End With

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

[DocAElstein]

Notes in support of this Forum Question:
https://www.eileenslounge.com/viewtopic.php?f=18&t=33834

Trying to figure out how Excel Clipboard ( or maybe Office clipboard ) is interacting with the Windows clipboard when trying to paste into Excel a text string,….

I have a text string. I add to it, manipulate it a bit, then put it in "the clipboard", ( probably the windows clipboard ) , then do an Excel Worksheets Paste …

Simplified example…
I have this already in a string,
"A" & vbCr & vbLf & "C"
Seen in another way:
A_vbCr_vbLf_B
The first representation is in a typical code line convention, the second an attempt at a more "real" view
There are 4 characters there. The middle two are examples of types that are often referred to as "invisible" characters. (These two typically instruct systems to go to a new line)
Most software that visibly gives you some sort of text to see , would usually interpret that as two lines of text. For example, Excel would usually interpret that such as to display you something like this, if you somehow "put it in" the start ( top left ) of a spreadsheet:
Row\Col
A

1A


2C


I want to put an extra cell with split line text in it, simplified like this:
Row\Col
A

1A


2X
Y


3C


Sometime or other I have learnt that Excel recognises a single vbLf to split up lines of text within a cell. But it turns out to be bit more complicated than that if you want the text string in the Windows Clipboard to come out as you want it in Excel.

The second part of this macro seems to usually achieve the second screenshot above

Sub TestvbLf_1()
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim StringBack As String
' Fill two rows , in 1 column
ActiveSheet.Cells.Clear ' This is important to remove any formatting that might distort results
objDataObject.SetText "A" & vbCr & vbLf & "C": objDataObject.PutInClipboard
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack) ' "A" & vbCr & vbLf & "C"
' Put an extra cell with split line text in it
ActiveSheet.Cells.Clear '
objDataObject.SetText "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C": objDataObject.PutInClipboard
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack) ' "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C"

End Sub

( The function, WtchaGot( ) can be found here: http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=10946&viewfull=1#post10946 )



Here are some further sample code snippets and discussions

This code snippet suggest to me that the Windows clipboard is being used, as .Clear does not empty "the clipboard" , as one more typically annoyingly experiences in Excel work when copying things manually or with VBA in Excel

Sub TestvbLf_2()
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim StringBack As String

' Put an extra cell with split line text in it
ActiveSheet.Cells.Clear '
objDataObject.SetText "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C": objDataObject.PutInClipboard
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack) ' --- "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C"

ActiveSheet.Cells.Clear ' This does not clear the clipboard, so next line gives the same results, which...
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1") ' suggests that the Windows clipboard is being used
Call WtchaGot(StringBack) ' --- "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C"
'
End Sub
Finally we see this, the orange of the clipboard icon indicating something is in "the clipboard", presumably the windows clipboard, since , as said, .Clear does not clear that icon, and also we see that the office clipboard is empty…
TestvbLf_2.JPG : https://imgur.com/dEbsaPE
2565

( Using Excel 2007 32 bit )

A19 Dez 2019
Lenf is 11A
"X
Y"
C

X
Y1 A65

C2 13

3
10

4 "34

5 X88

6
10

7 Y89

8 "34

9 13

10
10

11 C67
Worksheet: WotchaGotInString
The second two columns are produced by function WtchaGot( ) , and give a breakdown of the 11 characters in the string:
"A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C"
A vbCr vbLf " X vbLf Y " vbCr vbLf C

Further investigation in next post

[DocAElstein]

In support of these posts

https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767
https://www.eileenslounge.com/viewtopic.php?f=18&t=33834



Thoughts on adding split lines in Excel cells via the ( probably windows ) Clipboard

The following code snippet is typical of those which got me to the solution of how to manipulate a text string so that it pastes into Excel a cell with multiple lines.
The first section shows me what the text in "the clipboard" looks like after using Excel ways to copy my final desired test form , after using Excel ways to produce it. It gives this sort of output
"A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C" & vbCr & vbLf
A vbCr vbLf " X vbLf Y " vbCr vbLf C vbCr vbLf
TestvbLf_3.jpg : https://imgur.com/oPXJIkG
2566

Either code sections 2 and 3 would error, presumably because the windows clipboard has been emptied. That is not totally understandable. We know that we had something in the windows clipboard. Doing things that empty "clipboards" , possibly other than the window clipboard, seem also somehow to remove things from the windows clipboard.
Possibly we could explain this by saying that as Excel filled the windows clipboard as a sort of extra thing to do after primarily filling its clipboard, then some linking wiring in place to do that also resulted into it clearing the windows clipboard when it cleared its clipboard
Code section 4 erroring is less understandable, as we did not use normal Excel ways to fill the window clipboard, but never the less .Clear seems to empty it.
Code section 5 erroring is similarly less understandable, since it is generally considered that Application.CutCopyMode = False clears the Excel clipboard

Before going on to sections 7 and 8, copy something to the "clipboard" from anywhere.
We find that section 7 and 8 would still error. This once again seems to be caused by either .Clear or .CutCopyMode = False. It suggests that there is some link to the windows clipboard that causes it to be cleared. It suggests perhaps that something has been set to link things in the windows clipboard from Excel or office, possibly to get some formatting parameters. If you put anything into the windows clipboard, it will still be cleared when doing .Clear or .CutCopyMode = False , by virtue of this linking "wiring"

Section 9 probably removes this linking wiring.
When a manual copy is then made in the following sections , possibly a new wiring is set up which has a different sort of dependency.

Before going on to section 10 and then again before going on to section 11, copy something to the "clipboard" from anywhere.
The code lines of .Clear or .CutCopyMode = False at the start of these sections do not remove the orange from the icon top left, and code sections 10 and 11 do not error. This supports the idea that a link was made to the windows clipboard that works slightly differently.




Sub TestvbLf_3()
ActiveSheet.Cells.Clear


Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim StringBack As String
' Section 1
ActiveSheet.Range("A1").Value = "A"
ActiveSheet.Range("A2").Value = "X" & vbLf & "Y"
ActiveSheet.Range("A3").Value = "C"
ActiveSheet.Range("A1:A3").Copy
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack)
'ActiveSheet.Cells.Clear ' --- This clears "the clipboard",
ActiveSheet.Paste Destination:=ActiveSheet.Range("D1")

' Section 2
' ActiveSheet.Cells.Clear ' --- This clears "the clipboard"
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText() ' This errors
' Call WtchaGot(StringBack)

' Section 3
' Application.CutCopyMode = False
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText() ' This errors
' Call WtchaGot(StringBack)

' Section 4
' objDataObject.SetText "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C": objDataObject.PutInClipboard
' ActiveSheet.Cells.Clear
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText() ' This errors
' Call WtchaGot(StringBack)

' Section 5
' objDataObject.SetText "A" & vbCr & vbLf & """" & "X" & vbLf & "Y" & """" & vbCr & vbLf & "C": objDataObject.PutInClipboard
' Application.CutCopyMode = False
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
' Call WtchaGot(StringBack)

Stop ' BEFORE DOING THE NEXT CODE SECTIONs, copy something manually via Ctrl+c ...
' Section 7
' ActiveSheet.Cells.Clear
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText() ' This errors
' Call WtchaGot(StringBack)
'
'' Section 8
' Application.CutCopyMode = False
' objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText() ' This errors
' Call WtchaGot(StringBack)

' Section 9
ActiveSheet.Cells.Clear ' This I think breaks the link from other clipboards to the windows clipboard.
' Application.CutCopyMode = False ' this line as alternative to the last has the same effect

Stop ' BEFORE DOING THE NEXT CODE SECTIONs, copy something manually via Ctrl+c ...

' Section 10
ActiveSheet.Cells.Clear
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack)
ActiveSheet.Paste Destination:=ActiveSheet.Range("E1")

Stop ' BEFORE DOING THE NEXT CODE SECTIONs, copy something manually via Ctrl+c ...

' Section 11
Application.CutCopyMode = False
objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Call WtchaGot(StringBack)
ActiveSheet.Paste Destination:=ActiveSheet.Range("H1")

End Sub

[DocAElstein]

Some notes in support of these Threads
http://www.eileenslounge.com/viewtopic.php?f=18&t=33775
http://www.eileenslounge.com/viewtopic.php?f=18&t=33834&sid=f48aa968fa8fe7f9f789cda2d0d7141c#p262009
http://www.excelfox.com/forum/showthread.php/2384-VPN-Forum-access-and-IP-addresse-Tests?p=11570&viewfull=1#post11570
http://www.excelfox.com/forum/showthread.php/2384-VPN-Forum-access-and-IP-addresse-Tests?p=11608&viewfull=1#post11608



VPN and IP Addresses
Some of the initial investigations into testing VPN and in looking at problems showed that it was useful to be able to monitor various IP addresses.
The main (Public) address, as already discussed, ( http://www.excelfox.com/forum/showthread.php/2384-VPN-Forum-access-and-IP-addresse-Tests?p=11597&viewfull=1#post11597 ) , is of course important to know . There is also a "local host", which more typically is set to the same number for everyone, (127.0.0.1 ). This is a number which conventionally is used to allow direct access to network aspects of your computer which might otherwise be accessed externally in some way or another. A characteristic of VPN software is that it manipulate your computer in a way such that, amongst other things , this number will change to the internal address used at your VPN provider to identify you within their system. It is part of the trickery in the Client software, that you "looking at yourself" gets manipulated into looking somewhere else. The provider in some ways is then in control of your computer allowing them to give the impression that your computer is physically somewhere else: Part of your computer "Soul" is with them.

Public address
Manually this is achieved typically by visiting various sites that provide you with this information. The automated way still needs to use such sites. The reason for this is that you need to be able to get the information by accessing yourself in the way that another computer connected to the internet "gets at you". Part of this process involves obtaining your public address as you communicate initially with them. We could scrap any site offering the service and pick out the IP address information.
We can simplify the coding to do this by accessing a site available which only gives the IP information, and which shows as the website that you "see" just that IP address number.
So for example if you type in your browser URL bar, http://myip.dnsomatic.com/ , then all you will see is the IP address. You will even see only that if you are in Google Chrome Browser and right click and view the Page Source
Page Source myip dnsomatic .JPG : https://imgur.com/uceUKE4

This information will be the entire .responseText received back. In normal scrapping coding you might feed this supplied text string into an object model software which allows you to then pick out using OOP type techniques what you want. If we use the site http://myip.dnsomatic.com/ , we don't need to take that extra step, and can simply view the entire .responseText , as this is the exact info we want.

( I found that sometimes the first one or few attemps did not work in the next coding, but almost always after a few attemopts it worked. So the recursion technique is used to call the Function a few times , if necerssary )


Option Explicit
Sub TestPubicIP()
Dim strIP As String
Call PubicIP(strIP)
MsgBox prompt:=strIP
'Call WtchaGot(strIP)
End Sub
' Because we have ByRef PublicIP , the is effectively taking the variable strIP into the function, and similarly in the recursion Call line that variable is taken. Hopefull in one of the 5 attepts at running the Function it will be filled.. We don't actually fill the pseudo variable PubicIP so no value is returned directly by the Function. (So we could have used a Sub()routine instead) To get a returned value we look at the value in strIP after runing the routine , because , as said, hopefully that particular variable will have been added to
Function PubicIP(ByRef PublicIP As String, Optional ByVal Tries As Long) As String
If Tries = 5 Then Exit Function
On Error GoTo Bed
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://myip.dnsomatic.com", True ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
'.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
Let PublicIP = PageSrc: ' Debug.Print PubicIP
'Call WtchaGot(PubicIP)
If PublicIP = "" Then Call PubicIP(PublicIP, Tries + 1) ' Recursion Call line. I do this because sometines it seems to need more than one try before it works
Exit Function
Bed:
Let PubicIP = Err.Number & ": " & Err.Description: Debug.Print PubicIP
End Function


As an alternative , I have below a similar coding. It gets the page source from another site which shows your IP address. I found when looking at the page source in Google Chrome, that I could see the IP address conveniently showing between two simple text lines :
Page Source whatismyipaddress_com .JPG : https://imgur.com/LSvORAe
2567

To VBA ( or most computer things), that text looks like a long string, and at that point we can imagine that it looks to the computer like any one of these 3 representations
……. ipt -->" & vbLf & "87" & "." & "101" & "." & "95" & "." & "204" & vbLf & "<!—do not scr……..
…….ipt --> vbLf 87.101.95.204 vbLf <!—do not scr ………….

…….ipt --> vbLf
87.101.95.204 vbLf
<!—do not scr ………….

We apply some simple VBA strings manipulation techniques to extract just the IP address number

'
Sub TestPubicIPwhatismyipaddress_com()
Dim strIP As String
Let strIP = PubicIPwhatismyipaddress_com
MsgBox prompt:=strIP
End Sub
Function PubicIPwhatismyipaddress_com() As String
On Error GoTo Bed
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://whatismyipaddress.com/de/meine-ip", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
'.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .READYSTATE <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responsetext ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
Let PubicIPwhatismyipaddress_com = PageSrc: ' Debug.Print PubicIPwhatismyipaddress_com
Dim IPadres As String, posIPadres1 As Long, posIPadres2 As Long
Let posIPadres1 = InStr(1, PageSrc, "<!-- do not script -->", vbBinaryCompare) ' Screenshot ---> Page Source whatismyipaddress_com .JPG : https://imgur.com/LSvORAe
Let posIPadres2 = InStr(posIPadres1 + 1, PageSrc, "<!-- do not script -->", vbBinaryCompare)
Let PubicIPwhatismyipaddress_com = Mid(PageSrc, posIPadres1 + 23, ((posIPadres2 - 1) - (posIPadres1 + 23)))
Call WtchaGot(PubicIPwhatismyipaddress_com)
Exit Function
Bed:
Let PubicIPwhatismyipaddress_com = Err.Number & ": " & Err.Description: Debug.Print PubicIPwhatismyipaddress_com
End Function



Local Host address and computer name in the next post

[DocAElstein]

Local Host address, Computer name
There are a couple of Win32 APIs which will get this information.
We just need to write a small amount of coding to get the function to do what we want and also a bit of manipulaation to give the information as we need it.
For the computer name this is simply a function to give us a string.

Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long
' "GetComputerNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long
Function ComputerName() As String ' GHB and sex..
Dim NmeLen As Long, lngX As Long, strCompName As String
Let NmeLen = 999: Let strCompName = " " ' variables must be initialised or API things often dont work ' String$(50, 0)
Let lngX = GetComputerName(strCompName, NmeLen) '
If lngX <> 0 Then ' returns 1 if it works
Let ComputerName = strCompName ' Left$(strCompName, NmeLen) ' The first argument variable gets like a LSet done on it
Else
Let ComputerName = "Couldn't get Computer name"
End If
Let ComputerName = Left$(ComputerName, NmeLen) ' We must do this as there is a Chr(0) after the name .... Let ComputerName = Trim(ComputerName) ' this is no good, - it leaves Chr(0) on the end which means that ComputerName is the last thing that will get printed
'Call WtchaGot(ComputerName)
End Function






The Win32 API for the local IP address is slightly more complicated. It will give us a table/ array of all the IP addresses held. The first is generally that we are interested in. it seems to be added when a VPN connection is made

Option Explicit
Private Declare Function GetIpAddrTable_API Lib "IpHlpApi" Alias "GetIpAddrTable" (ByRef pIPAddrTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long ' http://www.source-code.biz/snippets/vbasic/8.htm
' "GetIpAddrTable" (ByRef pIPAddrTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Public Function GetIpAddrTable() As String ' Christian d'Heureuse, www.source-code.biz http://www.source-code.biz/snippets/vbasic/8.htm
Rem 1 We give the API function some info , and that seems to make it fill up an array with table values
Dim Buf(0 To 1234) As Byte ' Buf(0 To 511) As Byte ' must be Byte or overflow at NrOfEntries
Dim BufSize As Long: Let BufSize = 12345
Dim rc As Long: Let rc = GetIpAddrTable_API(Buf(0), BufSize, 1)
'If rc <> 0 Then Err.Raise vbObjectError, , "GetIpAddrTable failed with return value " & rc
Dim NrOfEntries As Integer: NrOfEntries = Buf(1) * 256 + Buf(0)
'If NrOfEntries = 0 Then GetIpAddrTable = Array(): Exit Function

Dim i As Long
For i = 0 To NrOfEntries - 1
Dim j As Long, s As String
For j = 0 To 3
Dim Indcy As Long: Let Indcy = 4 + i * 24 + j
s = s & IIf(j > 0, ".", "") & Buf(Indcy): Debug.Print Indcy & " " & Buf(Indcy) ' This code line just builds the final string for each IP address, with a "." before all but the first of the 4 number parts --- for example like 192 . 168 . 2 . 110
Next j
Dim strIPs As String: Let strIPs = strIPs & " " & s: Let s = ""
Next
GetIpAddrTable = strIPs: Debug.Print strIPs
End Function

' 4 127
' 5 0
' 6 0
' 7 1
' 28 192
' 29 168
' 30 2
' 31 110
' 127.0.0.1 192.168.2.110 ' _

' 4 10
' 5 132
' 6 13
' 7 113
' 28 127
' 29 0
' 30 0
' 31 1
' 52 192
' 53 168
' 54 2
' 55 110
' 10.132.13.113 127.0.0.1 192.168.2.110
' 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
' 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
' 49 50 51 52 53 54 55
' 10 132 13 127
' 127 0 0 1
' 192 168 2 110


If we examine that coding above, and experiment with what it does, we see a couple of things:
Rem 1
_ It is doing a strange thing, as API's often do. That is to say the API works similarly to a normal VBA function, except the way each argument is a mystery.. following some set of rules/coding which probably the author wrote when he was drunk and no one can remember anymore.
You must make an array of Byte types. The array should be fairly big.
You must give the first array element and the size of the array to the API Function.
Then magically the array gets filled. Presumably some internally held table is put into the array
Rem 2
A bit of maths is done to pick out the elements we want from the returned filled array

The final analysis here of a typical output can be helpful to try and understand another way to get this information

' 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
' 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
' 49 50 51 52 53 54 55
' 10 132 13 127
' 127 0 0 1
' 192 168 2 110

Or maybe not. I am not sure. I doubt many people are…

[DocAElstein]

Coding in support of this post
http://www.excelfox.com/forum/showthread.php/2392-VBA-Copy-files-in-excel-edit-and-save?p=11808&viewfull=1#post11808



Option Explicit '
Sub txtfilesinworksheetwithFILENAMEColumnB() ' http://www.excelfox.com/forum/showthread.php/2392-VBA-Copy-files-in-excel-edit-and-save?p=11808&viewfull=1#post11808
Rem 1 Worksheets info
Dim WsFlNme As Worksheet
Set WsFlNme = ThisWorkbook.Worksheets("FILENAME")
Rem 2 Copy .txt files in worksheets
'2a) Copy .txt files in worksheet with FILENAME (Column B)
'2a)(i) Get the entire text file as a string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Dim PathAndFileName As String, strtxtFile As String
Let PathAndFileName = ThisWorkbook.Path & "\vbadumb.txt"
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
strtxtFile = VBA.Strings.Space$(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , strtxtFile 'The Get statement reads back from an open route to data into the given variable
Close #FileNum
' Call WtchaGot(strtxtFile) ' --- If we were to examine that string in strtxtFile, then we would see something like "1" & vbCr & vbLf & "2" & vbCr & vbLf & "3"
Rem 3 Put the text data inti the (Windows clipboard)
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dataobject-object A holding area for formatted text data used in transfer operations. Also holds a list of formats corresponding to the pieces of text stored in the DataObject. .....
' .....A DataObject can contain one piece of text for the Clipboard text format, and one piece of text for each additional text format, such as custom and user-defined formats. A DataObject is distinct from the Clipboard. A DataObject supports commands that involve the Clipboard and drag-and-drop actions for text. When you start an operation involving the Clipboard (such as GetText) or a drag-and-drop operation, the data involved in that operation is moved to a DataObject. The DataObject works like the Clipboard. If you copy a text string to a DataObject, the DataObject stores the text string. If you copy a second string of the same format to the DataObject, the DataObject discards the first text string and stores a copy of the second string. It stores one piece of text of a specified format and keeps the text from the most recent operation.
objDataObject.SetText strtxtFile: objDataObject.PutInClipboard ' This often seems to result in putting infomation into the Windows Clipboard
Rem 4 Paste out to the worksheet
WsFlNme.Paste Destination:=WsFlNme.Range("B1") ' If we paste the entire string in / at B1 , then the vbCr & vbLf in the string will be interpreted by Excel as the row seperator, so the entire string will be split over 3 lines
End Sub

[DocAElstein]

In support of theses Threads:
http://www.eileenslounge.com/viewtopic.php?f=21&p=249846#p249846
http://www.excelfox.com/forum/showthread.php/2336-Excel-and-XP-Operating-System-Tests-(proc-entry-pt-quot-GetDataFormEX-quot-not-found-in-the-DLL-quot-KERNEL32)
http://www.excelfox.com/forum/showthread.php/2242-Excel-2003-ActiveX-controls-embedded-in-worksheet-not-working-then-can%E2%80%99t-even-insert-them-*SOLVED*?p=10923&viewfull=1#post10923





The procedure entry point "EnumCalendarInfoExEx" was not found in the DLL "KERNEL32.dll"


I thought I had been sensible and chosen a safe option in XP of download but manually determine Install time
Updates Option Download but manually determine Install time.jpg : https://imgur.com/ocsOVbl , https://imgur.com/X0eB8AG
But somehow I got a full load of updates at some point recently on one of my XP machines, possibly at the point of turning the Laptop off.

I noted manually all the office updates and did various comparisons with my list of "Good" and "Bad" updates, but that only revealed as possible bads , the Active X control Killer , KB3054873. Sure enough my control buttons were dead, but after removing KB3054873. They immediately started working again.

None of the XP killing known bads were found, but some I have not previously seen were found.
Update für Microsoft Outlook 2010 (KB4475604) 32-Bit-Edition Letzte Änderung: 08.10.2019
Sicherheitsupdate für Microsoft Excel 2010 (KB4484130) 32-Bit-Edition Letzte Änderung: 03.10.2019
Sicherheitsupdate für Microsoft Office 2010 (KB4475569) 32-Bit-Edition Letzte Änderung: 03.10.2019
Sicherheitsupdate für Microsoft Office 2010 (KB4475599) 32-Bit-Edition Letzte Änderung: 05.09.2019
Sicherheitsupdate für Microsoft Office 2010 (KB4464566) 32-Bit-Edition Letzte Änderung: 05.09.2019
Sicherheitsupdate für Microsoft Word 2010 (KB4475533) 32-Bit-Edition Letzte Änderung: 08.08.2019
Update für Microsoft Filter Pack 2.0 (KB3114879) 32-Bit-Edition Letzte Änderung: 09.07.2019


https://www.catalog.update.microsoft...px?q=KB4475604
Updatedetails
Update für Microsoft Outlook 2010 (KB4475604) 32-Bit-Edition
Letzte Änderung: 08.10.2019
Größe: 79,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Outlook 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Outlook 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4475604
Weitere Informationen:
https://support.microsoft.com/kb/4475604
Support-URL:
https://support.microsoft.com/?LN=de-de

https://www.catalog.update.microsoft...px?q=KB3114879
Updatedetails
Update für Microsoft Filter Pack 2.0 (KB3114879) 32-Bit-Edition
Letzte Änderung: 09.07.2019
Größe: 4,4 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Filter Pack 2.0 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Filter Pack 2.0 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 3114879
Weitere Informationen:
https://support.microsoft.com/kb/3114879
Support-URL:
https://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft...px?q=KB4475604
Updatedetails
Update für Microsoft Outlook 2010 (KB4475604) 32-Bit-Edition
Letzte Änderung: 08.10.2019
Größe: 79,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Outlook 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Outlook 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4475604
Weitere Informationen:
https://support.microsoft.com/kb/4475604
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft...px?q=KB4464566
Updatedetails
Sicherheitsupdate für Microsoft Office 2010 (KB4464566) 32-Bit-Edition
Letzte Änderung: 05.09.2019
Größe: 8,2 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4464566
Weitere Informationen:
https://support.microsoft.com/kb/4464566
Support-URL:
https://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft...px?q=KB4475533
Updatedetails
Sicherheitsupdate für Microsoft Word 2010 (KB4475533) 32-Bit-Edition
Letzte Änderung: 08.08.2019
Größe: 13,3 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Word 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Critical
KB-Artikelnummern: 4475533
Weitere Informationen:
https://support.microsoft.com/kb/4475533
Support-URL:
https://support.microsoft.com/?LN=de-de



https://www.catalog.update.microsoft...px?q=KB4484130
Updatedetails
Sicherheitsupdate für Microsoft Excel 2010 (KB4484130) 32-Bit-Edition
Letzte Änderung: 03.10.2019
Größe: 19,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Excel 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4484130
Weitere Informationen:
https://support.microsoft.com/kb/4484130
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft...px?q=KB4475599
Updatedetails
Sicherheitsupdate für Microsoft Office 2010 (KB4475599) 32-Bit-Edition
Letzte Änderung: 05.09.2019
Größe: 2,9 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4475599
Weitere Informationen:
https://support.microsoft.com/kb/4475599
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft...px?q=KB4475569
Updatedetails
Sicherheitsupdate für Microsoft Office 2010 (KB4475569) 32-Bit-Edition
Letzte Änderung: 03.10.2019
Größe: 1,7 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4475569
Weitere Informationen:
https://support.microsoft.com/kb/4475569
Support-URL:
https://support.microsoft.com/?LN=de-de



Unfortunately removing all those did not cure the XP problem, even after a computer restart.

I tried a simple coding to compare a previous updates list from January 2019 to that for now, at December, 2019

Option Explicit
Sub compareJan2019ToDec2019() ' Laptop Froggy december 2019 .... The procedure entry point "EnumCalendarInfoExEx" was not found in the DLL "KERNEL32.dll" The procedure entry point "EnumCalendarInfoExEx" was not found in the DLL "KERNEL32.dll"
' Updates from last January
Dim rngSrch As Range: Set rngSrch = Worksheets("Frogy29thjan2019").Range("A1:A" & Worksheets("Frogy29thjan2019").UsedRange.Rows.Count & "")
' Update list for December after killing downloads came probably after turning off computer
Dim rngDecUpdts As Range: Set rngDecUpdts = Worksheets("Froggy30thDec2019").Range("A1:A" & Worksheets("Froggy30thDec2019").Range("A" & Rows.Count & "").End(xlUp).Row & "")
'
Dim rng As Range
For Each rng In rngDecUpdts
Dim varMtch As Variant
Let varMtch = Application.Match(rng, rngSrch, 0)
If IsError(varMtch) Then
MsgBox prompt:=rng.Value
Dim strMsg As String
Let strMsg = strMsg & rng.Value & vbCr & vbLf
Else
End If
Next rng
MsgBox prompt:=strMsg: Debug.Print strMsg ' Fron VB Editor , Hit Ctrl+g , then you can copy the list from the Immediate window which should come up after hitting Ctrl+g
End Sub
This was the result for new updates:
KB3114879
KB4475604
KB2589318
KB4462172
KB4464566
KB4475533
KB3115314
KB4484130
KB4475599
KB4475569
KB4018363
KB3114559
KB4461626



……………….Continued in next post………………………..



Ref
https://www.catalog.update.microsoft.com/Home.aspx

[DocAElstein]

………………….from last post……………..


So looking further at these "new" updates:
KB3114879
KB4475604
KB2589318
KB4462172
KB4464566
KB4475533
KB3115314
KB4484130
KB4475599
KB4475569
KB4018363
KB3114559
KB4461626

https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462172
Update für Microsoft Office 2010 (KB4462172) 32-Bit-Edition
Letzte Änderung: 13.02.2019
Größe: 7,1 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Office 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Office 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4462172
Weitere Informationen:
https://support.microsoft.com/kb/4462172
Support-URL:
https://support.microsoft.com/?LN=de-de



https://www.catalog.update.microsoft.com/Search.aspx?q=KB4461626
Update für Microsoft Office 2010 (KB4461626) 32-Bit-Edition
Letzte Änderung: 12.03.2019
Größe: 2,6 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Office 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Office 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4461626
Weitere Informationen:
https://support.microsoft.com/kb/4461626
Support-URL:
https://support.microsoft.com/?LN=de-de


https://www.catalog.update.microsoft.com/Search.aspx?q=KB4018363
Update für Microsoft Access 2010 (KB4018363) 32-Bit-Edition
Letzte Änderung: 12.03.2019
Größe: 7,3 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Access 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Access 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4018363
Weitere Informationen:
https://support.microsoft.com/kb/4018363
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft.com/Search.aspx?q=KB2589318
Update für Microsoft Office 2010 (KB2589318) 32-Bit-Edition
Letzte Änderung: 10.08.2015
Größe: 747 KB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Office 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Office 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 2589318
Weitere Informationen:
http://support.microsoft.com/kb/2589318
Support-URL:
http://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft.com/Search.aspx?q=KB3115314
Update für Microsoft Visio 2010 (KB3115314) 32-Bit-Edition
Letzte Änderung: 13.02.2019
Größe: 19,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Visio 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Visio 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 3115314
Weitere Informationen:
https://support.microsoft.com/kb/3115314
Support-URL:
https://support.microsoft.com/?LN=de-de



https://www.catalog.update.microsoft.com/Search.aspx?q=KB3114559
Update für Microsoft Outlook 2010 (KB3114559) 32-Bit-Edition
Letzte Änderung: 09.04.2019
Größe: 355 KB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Outlook 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Outlook 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 3114559
Weitere Informationen:
https://support.microsoft.com/kb/3114559
Support-URL:
https://support.microsoft.com/?LN=de-de

So we have 6 "new" updates. But these appear on safe list

[DocAElstein]

Strangely ….
KB4461526 has appeared. So I De installed it
KB4461576 has appeared. So I De installed it
KB4461625 came back . So I De installed it again
KB4461625 came back once again . So I De installed it again
KB4464524 has appeared. So I De installed it.
KB4462230 has appeared. So I De installed it
KB4462223 has appeared. So I De installed it


After de installing KB4462223, Office started working



https://www.catalog.update.microsoft.com/Search.aspx?q=KB4461526
Sicherheitsupdate für Microsoft Word 2010 (KB4461526) 32-Bit-Edition
Letzte Änderung: 08.11.2018
Größe: 12,9 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Word 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4461526
Weitere Informationen:
https://support.microsoft.com/kb/4461526
Support-URL:
https://support.microsoft.com/?LN=de-de



https://www.catalog.update.microsoft.com/Search.aspx?q=KB4461576
Sicherheitsupdate für Microsoft Outlook 2010 (KB4461576) 32-Bit-Edition
Letzte Änderung: 07.12.2018
Größe: 79,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Outlook 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4461576
Weitere Informationen:
https://support.microsoft.com/kb/4461576
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft.com/Search.aspx?q=%20KB4464524%20
Update für Microsoft Outlook 2010 (KB4464524) 32-Bit-Edition
Letzte Änderung: 15.05.2019
Größe: 79,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Outlook 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Outlook 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4464524
Weitere Informationen:
https://support.microsoft.com/kb/4464524
Support-URL:
https://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462230
Sicherheitsupdate für Microsoft Excel 2010 (KB4462230) 32-Bit-Edition
Letzte Änderung: 04.04.2019
Größe: 19,8 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Excel 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4462230
Weitere Informationen:
https://support.microsoft.com/kb/4462230
Support-URL:
https://support.microsoft.com/?LN=de-de







https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462223
Sicherheitsupdate für Microsoft Office 2010 (KB4462223) 32-Bit-Edition
Letzte Änderung: 04.04.2019
Größe: 8,0 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4462223
Weitere Informationen:
https://support.microsoft.com/kb/4462223
Support-URL:
https://support.microsoft.com/?LN=de-de







At this point, I decide to go backwards, reinstalling those de installed updates in order to pin down the latest “bad” or “bads”


This is the list I have to try out on a re install
I will do it in backward order


KB3114879
KB4475604
KB2589318
KB4462172
KB4464566
KB4475533
KB3115314
KB4484130
KB4475599
KB4475569
KB4018363
KB3114559
KB4461626
KB4462187
KB4461579
KB4462177
KB4464567
KB4461521
KB4461526
KB4461576
KB4461625
KB4464524.
KB4462230
KB4462223

[DocAElstein]

Re installing in XP
Using Microsoft Update Catalog : https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462223
To install, type in the required update in the search box top right. Remember to include KB at the front Download KB from MicrosoftUpdateCatalog.JPG : https://imgur.com/AfSAtlC
Another window appears and you have one or more files to click on to download, https://imgur.com/bIWg243
After downloading you may need to save and / or open / unzip one or more files or do a double click on files to set off the installation or installations. The exact process to get the installation to start will vary depending on your exact system and settings


KB4462223 This breaks Office 2010 after re install , and note also that KB4461626 and KB4461623 and KB4461577 and KB4227170 appeared fir the first time ever!!!
So I de installed KB4462223 again.
All was then OK.

KB4462230
All is still OK after re instal.

KB4464524 ( 14.05.2019 )
This is a large amount of files to download, I have not got around to installing all of them yet.

KB4461625 ( 03.01.2019 )
This is a large amount of files to download, I have not got around to installing all of them yet

KB4461576 ( 06.12.2018 )
This is a large amount of files to download, I have not got around to installing all of them yet

KB4461526
All is still OK after re install

KB4461521
All is still OK after re install

KB4464567
All is still OK after re install

KB4462177
All is still OK after re install

KB4461579
All is still OK after re install

KB4462187
All is still OK after re install

KB4461626
All is still OK after re install

KB3114559
All is still OK after re install

KB4018363
All is still OK after re install

KB4475569
All is still OK after re install

KB4475599
All is still OK after re install

KB4484130
All is still OK after re install

KB3115314
All is still OK after re install

KB4475533
All is still OK after re install

KB4464566
This causes the XP problem
After de installing it the problem goes away.

KB4462172
All is still OK after re install

KB2589318
All is still OK after re install

KB4475604 ( 08.10.2019 )
This is a large amount of files to download, I have not got around to installing all of them yet

KB3114879
All is still OK after re install

So it appears that the two new "bads" are
KB4464566
KB4462223
And here were the previously known
KB4461522 ( no longer available )
KB4461614 ( available , but not been offered for some time )
KB4462157 ( available , but not been offered for some time. ( Originally this was introduced to solve the problem. It never did. Quite the opposite: If you have the problem, then installing this update has no effect; but if you do not have the problem , and you instal this update, it causes the problem, just as all the other "killers do !!. ) )
KB4462174 ( available, and until recently, was still offered )
KB4462223 : The latest, available, and being currently offered
http://www.eileenslounge.com/viewtopic.php?f=21&t=31405&p=249846#p249846
We see infact that the „hidden" KB4462223 is in fact, an already known „bad"



https://www.catalog.update.microsoft.com/Search.aspx?q=KB4464566
Sicherheitsupdate für Microsoft Office 2010 (KB4464566) 32-Bit-Edition
Letzte Änderung: 05.09.2019
Größe: 8,2 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4464566
Weitere Informationen:
https://support.microsoft.com/kb/4464566
Support-URL:
https://support.microsoft.com/?LN=de-de



https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462223
Sicherheitsupdate für Microsoft Office 2010 (KB4462223) 32-Bit-Edition
Letzte Änderung: 04.04.2019
Größe: 8,0 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4462223
Weitere Informationen:
https://support.microsoft.com/kb/4462223
Support-URL:
https://support.microsoft.com/?LN=de-de



KB4461522 No longer available


https://www.catalog.update.microsoft.com/Search.aspx?q=KB4461614
Sicherheitsupdate für Microsoft Office 2010 (KB4461614) 32-Bit-Edition
Letzte Änderung: 12.02.2019
Größe: 8,2 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4461614
Weitere Informationen:
https://support.microsoft.com/kb/4461614
Support-URL:
https://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462157
Update für Microsoft Office 2010 (KB4462157) 32-Bit-Edition
Letzte Änderung: 22.01.2019
Größe: 8,2 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft hat ein Update für Microsoft Office 2010 32-Bit-Edition veröffentlicht. Dieses Update stellt neueste Fixes für Microsoft Office 2010 32-Bit-Edition bereit. Darüber hinaus umfasst das Update Verbesserungen von Stabilität und Leistung.
Architektur: k.A.
Klassifikation: Wichtige Updates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Unspecified
KB-Artikelnummern: 4462157
Weitere Informationen:
https://support.microsoft.com/kb/4462157
Support-URL:
https://support.microsoft.com/?LN=de-de





https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462174
Sicherheitsupdate für Microsoft Office 2010 (KB4462174) 32-Bit-Edition
Letzte Änderung: 07.02.2019
Größe: 8,0 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4462174
Weitere Informationen:
https://support.microsoft.com/kb/4462174
Support-URL:
https://support.microsoft.com/?LN=de-de




https://www.catalog.update.microsoft.com/Search.aspx?q=KB4462223
Updatedetails
Sicherheitsupdate für Microsoft Office 2010 (KB4462223) 32-Bit-Edition
Letzte Änderung: 04.04.2019
Größe: 8,0 MB
Details:
Übersicht Sprachauswahl Paketdetails Installationsressourcen
Beschreibung: Microsoft Office 2010 32-Bit-Edition enthält ein Sicherheitsrisiko, das die Ausführung von willkürlichem Code ermöglicht, wenn eine in böswilliger Absicht veränderte Datei geöffnet wird. Dieses Sicherheitsrisiko wird mit diesem Update behoben.
Architektur: k.A.
Klassifikation: Sicherheitsupdates
Unterstützte Produkte: Office 2010
Unterstützte Sprachen: all
MSRC-Nummer: k.A.
MSRC-Sicherheit: Important
KB-Artikelnummern: 4462223
Weitere Informationen:
https://support.microsoft.com/kb/4462223
Support-URL:
https://support.microsoft.com/?LN=de-de
Schließen

[DocAElstein]

Test draft copy of forum answers associated with lates XP updates issues

http://www.eileenslounge.com/viewtopic.php?f=21&t=31405&p=249846#p249846
https://social.technet.microsoft.com/Forums/office/en-US/b8ba02ac-84a0-4a59-9371-159ac441b3bb/office-2010-updates-break-xp-procedure-entry-point-getdateformatex-could-not-be-located-in-the?forum=officeitproprevious
https://tinyurl.com/t73r3pg
https://social.technet.microsoft.com/Forums/en-US/badcaf77-9d90-477e-ad9d-c00e0d009327/the-procedure-entry-point-enumcalendarinfoexex-could-not-be-located-int-he-dynamic-link-library?forum=outlook
( ( Locked Threads:
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-mso_winother-mso_2010/ms-2010-apps-disabled-on-xp-os/dbef96a0-f858-46af-b05c-54dce16500c3?messageId=d954204b-33fe-4034-9da6-ea15c0dfbb7c&lc=1031&page=6
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_winother-mso_2010/microsoft-office-2010-on-an-xp-os/0cf7643f-1fa0-4ac5-98d1-bcda9dd9461f?messageId=e889ff6d-0a3e-41f5-baf7-4c6f3fb63739&page=4
https://answers.microsoft.com/en-us/msoffice/forum/all/ms-2010-apps-disabled-on-xp-os/dbef96a0-f858-46af-b05c-54dce16500c3?page=1
https://answers.microsoft.com/en-us/msoffice/forum/all/eeror-the-procedure-entry-point/cc792779-ac98-4211-a0b2-7df17e82fb3d )
)

I just finished unwrapping my Xmas present from Microsoft. It took me a couple of days. Despite having automatic updates disabled, occasionally a massive amount of updates still come down unexpectedly. It does not happen very often. I think theoretically it should never happen. But it does.

So one of my XP machines got the present.
I do have an extensive library of known "good and bad" Updates, and coding to sort through and compare them etc.. That usually helps identify the culprits. This time it only saw the old favourites that Microsoft like to send to cripple Active X controls, but never the less my XP was crippled by the issues discussed in this Thread.

I did identify some new updates that I had not seen before, but de installing them did not solve the problem , at least initially. After a lot of painstaking manual de installing and re installing updates I sorted the problem out…

It was very strange this time. By removing recent updates, I noticed that other updates suddenly appeared in the update this. They were not visible before. After removing some of those , the XP problem was solved. Furthermore I could re install most of the updated which I had originbally removed and still the XP problem does not return

Just to explain that again: In order to find the killer updates, you first have to de install some non offending updates. Only then do the killer updates show so that you can de install them. (A few other harmless updates may also suddenly appear). Then you can put the others back, if you like.

So finally below is the current list, with the recent ones at the bottom

If you don't find those,
or
you find some, de install them,
and still have the problem,
then try de installing a few other recent updates and then look at your update list again . If you then see any of the bad updates , then de install them. If that cures the problem then you may be able to re install some of the others you de installed without getting the problem.

In actual fact in my recent case, following the procedure that I have described, I now have all the updates that were showing after the unwanted Xmas present, and a few more, but I no longer have the problem, because I have de installed some of the bad updates, which were initially not showing after the unwanted present. Crazy situation!

Current Killer List
KB4461522 ( no longer available )
KB4461614 ( available , but not been offered for some time )
KB4462157 ( available , but not been offered for some time. ( Originally this was introduced to solve the problem. It never did. Quite the opposite: If you have the problem, then installing this update has no effect; but if you do not have the problem , and you instal this update, it causes the problem, just as all the other "killers do !!. ) )
KB4462174 ( available, and until recently, was still offered )
KB4462223
KB4464566 Probably the most recent killer
The last two may be hidden , and you may need to go through the steps I described to find them. Unfortunately I still have not figured out how to automate messing around with Office updates in XP ( I can do it with most everything else ). So you will need a few days to unwrap your present if you get one…




(P.s. Microsoft have locked some Threads on this, making it difficult to update people on the problem. But a few new Threads have also been started)

Ref:
https://social.technet.microsoft.com/Forums/office/en-US/b8ba02ac-84a0-4a59-9371-159ac441b3bb/office-2010-updates-break-xp-procedure-entry-point-getdateformatex-could-not-be-located-in-the?forum=officeitproprevious
https://tinyurl.com/t73r3pg
https://social.technet.microsoft.com/Forums/en-US/badcaf77-9d90-477e-ad9d-c00e0d009327/the-procedure-entry-point-enumcalendarinfoexex-could-not-be-located-int-he-dynamic-link-library?forum=outlook
Locked Threads:
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-mso_winother-mso_2010/ms-2010-apps-disabled-on-xp-os/dbef96a0-f858-46af-b05c-54dce16500c3?messageId=d954204b-33fe-4034-9da6-ea15c0dfbb7c&lc=1031&page=6
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_winother-mso_2010/microsoft-office-2010-on-an-xp-os/0cf7643f-1fa0-4ac5-98d1-bcda9dd9461f?messageId=e889ff6d-0a3e-41f5-baf7-4c6f3fb63739&page=4
https://answers.microsoft.com/en-us/msoffice/forum/all/ms-2010-apps-disabled-on-xp-os/dbef96a0-f858-46af-b05c-54dce16500c3?page=1
https://answers.microsoft.com/en-us/msoffice/forum/all/eeror-the-procedure-entry-point/cc792779-ac98-4211-a0b2-7df17e82fb3d

[DocAElstein]

In support of these Thread posts

http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
http://www.eileenslounge.com/viewtopic.php?f=30&t=33860&p=262344#p262344





Sub TestWtchaGot_Unic_NotMuchIfYaChoppedItOff()
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff("Laptop" & ChrW(8207) & ChrW(5))
End Sub
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make a Temporary Sheet, if not already there, in Current Active Workbook, for a simple list of all characters
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" 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 Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: 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 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: 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 ' 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
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' 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
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
MsgBox prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
End Sub
'

[DocAElstein]

Coding for this Thread post
http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11827&viewfull=1#post11827



Sub MakeFormulas4() ' http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11827&viewfull=1#post11827
Rem 1 ' Workbooks info
' 1a This months book, this workbook. It is the outout book for the current month
Dim ThisMonthsLatestBook As Workbook, LisWbName As String
Set ThisMonthsLatestBook = ThisWorkbook ' ActiveWorkbook
Let LisWbName = ThisMonthsLatestBook.Name
' If InStr(7, LisWbName, Format(Now(), "MMM"), vbTextCompare) = 0 Then MsgBox Prompt:="This workbook is not for " & Format(Now(), "MMMM"): Exit Sub
'Dim BookN As Long
' Let BookN = Mid(LisWbName, 5, InStr(5, LisWbName, "_", vbBinaryCompare) - 5)
' 1b Last months book
Dim strDteLisBk As String, DteLisBk As Date
Let strDteLisBk = Mid(LisWbName, 32, 8)
Dim LooksLikeADate As String: Let LooksLikeADate = Right(strDteLisBk, 2) & "." & Mid(strDteLisBk, 5, 2) & "." & Left(strDteLisBk, 4)
Let DteLisBk = CDate(LooksLikeADate) ' 31.12.2019 Looks like a date

Dim sourceBookName As String
' Let sourceBookName = "Book" & BookN - 1 & "_" & Format(DateAdd("m", -1, Now()), "MMM YYYY") & ".xlsm"
Let sourceBookName = "MSCI Equity Index Constituents " & Format(DateAdd("m", -1, DteLisBk), "YYYYMMDD") & ".xlsm"
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & sourceBookName)
Rem 2 Make records worksheet Sub MakeWorkSheetIfNotThere()
'Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" 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 Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
' Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: 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 '
If Not Evaluate("=ISREF(" & "'" & "Records" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "My Records"
ThisMonthsLatestBook.Worksheets.Add After:=ThisMonthsLatestBook.Worksheets.Item(Worksh eets.Count) 'A sheeet is added and will be Active
Dim wsRcds As Worksheet '
Set wsRcds = ThisMonthsLatestBook.Worksheets.Item(ThisMonthsLat estBook.Worksheets.Count) 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: 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 ' 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
wsRcds.Activate: wsRcds.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let wsRcds.Name = "Records"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set wsRcds = ThisWorkbook.Worksheets("Records")
End If
' End Sub
Rem 3 looping through worksheets
Dim C As Long, I As Long
'C = ActiveWorkbook.Worksheets.Count
'Let C = ThisWorkbook.Worksheets.Count
Let C = ThisMonthsLatestBook.Worksheets.Count - 1 ' -1 since last worksheet is records worksheet
'For I = 1 To C
'Application.ScreenUpdating = True
For I = 1 To C ' Sheet1 , Sheet2 , Sheet3 .......
'what are our worksheets? I = 1 , 2 , 3 ..........
Dim sourceSheet As Worksheet
Set sourceSheet = sourceBook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........

'Determine last row of source
With sourceSheet
Dim SourceLastRow As Long
SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With outputSheet
'Determine last row in col P
Dim OutputLastRow As Long
OutputLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
End With
'Apply our formula in records worksheet
With Worksheets("Records")
Let .Cells.Item(1, I).Value = sourceSheet.Name ' Header in column as worksheet name
'.Range("Q2:Q" & OutputLastRow).Formula = "=VLOOKUP($A2,'[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
.Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = "=VLOOKUP(" & outputSheet.Name & "!$A2,'" & sourceBook.Path & "\" & "[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
' .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value
End With
'MsgBox ActiveWorkbook.Worksheets(I).Name
MsgBox ActiveWorkbook.Worksheets.Item(I).Name
Next I
'Next P
Rem 4
Dim cel As Range
With Worksheets("Records").UsedRange
For Each cel In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If IsError(cel.Value) Then
'
Else
If cel.Value < 3 Then
cel.Font.Color = vbRed
Else
cel.Font.Color = vbGreen
End If
End If
Next cel
End With

'Close the source workbook, don't save any changes
sourceBook.Close False
' Application.ScreenUpdating = True
End Sub




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_- (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

Coding in support of these Thread posts
http://www.excelfox.com/forum/showthread.php/2384-VPN-Forum-access-and-IP-addresse-Tests?p=11569&viewfull=1#post11569
http://www.excelfox.com/forum/showthread.php/2384-VPN-Forum-access-and-IP-addresse-Tests?p=11672&viewfull=1#post11672






Sub ipconfigall_routeprint(Optional ByVal Msg As String) '
Rem 1 ipconfig /all
Shell "cmd.exe /c ""ipconfig /all > """ & ThisWorkbook.Path & "\ipconfig__all.txt"""""
' Get the entire text file as a string
Dim FileNum As Long: Let FileNum = FreeFile(1) '
Dim PathAndFileName As String, strIPcon As String
Let PathAndFileName = ThisWorkbook.Path & "\ipconfig__all.txt"
' Let PathAndFileName = ThisWorkbook.Path & "\test2B.txt" ' Al
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
strIPcon = VBA.Strings.Space$(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , strIPcon
Close #FileNum
' Tidy the string
Let strIPcon = Replace(strIPcon, vbCr & vbCr, vbCr, 1, -1, vbBinaryCompare)
Let strIPcon = Replace(strIPcon, vbTab, " ", 1, -1, vbBinaryCompare)
' add any extra info to string
Dim PublicIP As String: Call PubicIP(PublicIP)
Let strIPcon = "ipconfig /all route print" & Msg & vbCr & vbLf & ComputerName & vbCr & vbLf & GetIpAddrTable & vbCr & vbLf & PublicIP & vbCr & vbLf & vbCr & vbLf & """" & Format(Now, "DD MMM YYYY") & " " & vbLf & " " & Format(Now, "hh mm ss") & """" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & strIPcon ' vbLf is recognised as a new line within an Excel"
' String content check
' Call WtchaGot(strIPcon)
' put the text in the clipboard
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDataObject.SetText strIPcon: objDataObject.PutInClipboard

' Excel Worksheet
Dim Ws As Worksheet: Set Ws = ActiveSheet
Dim Clm As Range, NxtClm As Long
Set Clm = Ws.Cells.Find(What:="*", After:=Ws.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Clm Is Nothing Then
Let NxtClm = 2
Else
Let NxtClm = Clm.Column + 1
End If
' Put in next free column in Active sheet
Ws.Paste Destination:=Ws.Cells.Item(1, NxtClm)
' Ws.Columns.AutoFit: Ws.Rows.AutoFit

Rem 2 route print
Shell "cmd.exe /c ""route print > """ & ThisWorkbook.Path & "\route_print.txt"""""
' Get the entire text file as a string
Let FileNum = FreeFile(1) ' ' The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Dim strrouteprint As String
Let PathAndFileName = ThisWorkbook.Path & "\route_print.txt"
' Let PathAndFileName = ThisWorkbook.Path & "\test2B.txt" ' Al
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
strrouteprint = VBA.Strings.Space$(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , strrouteprint
Close #FileNum
' Tidy the string
Let strrouteprint = Replace(strrouteprint, vbCr & vbCr, vbCr, 1, -1, vbBinaryCompare)
Let strrouteprint = Replace(strrouteprint, vbTab, " ", 1, -1, vbBinaryCompare)
' put the text in the clipboard
objDataObject.SetText strrouteprint: objDataObject.PutInClipboard
' Excel Worksheet
Dim Lr As Long: Let Lr = Ws.Cells(Ws.Rows.Count, NxtClm).End(xlUp).Row
' Put in next free column in Active sheet
Ws.Paste Destination:=Ws.Cells.Item(Lr + 30, NxtClm)
Ws.Columns.AutoFit: Ws.Rows.AutoFit
ActiveWindow.Panes(2).Activate
Ws.Cells.Item(1, NxtClm).Select
End Sub
'

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias

Summary worksheet, before

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

1VoucherDateLink


2Go To Sheet


3Go To Sheet


4
Worksheet: Summary

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias

_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )

01.01.2020_99909900 - A01.01.2020_88888888 - F01.01.2020_88888886 - D01.01.2020_88888887 - E02.01.2020_99909900 - A03.01.2020_99909900 - A04.01.2020_88888888 - F05.01.2020_88888888 - F06.01.2020_88888888 - F07.01.2020_88888888 - F08.01.2020_88888888 - F09.01.2020_88888888 - F10.01.2020_99909900 - A11.01.2020_99909900 - A12.01.2020_99909900 - A13.01.2020_99909900 - A14.01.2020_99909900 - A15.01.2020_99909900 - A
Worksheet: arrUnicDtsSrc

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias


_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item BLLL00011311318.9E+07F113113101.01.2020_88888888 - F

01.01.20205Item CLLL000555027508.9E+07F5550275001.01.2020_88888888 - F

01.01.20201Item DABC1231200020008.9E+07D12000200001.01.2020_888888 86 - D

01.01.20204Item DLLL00011311318.9E+07E113113101.01.2020_88888887 - E

01.01.20205Item ELLL000555027508.9E+07F5550275001.01.2020_88888888 - F

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

01.01.20201Item AABC1231200020001E+08A12000200001.01.2020_99909900 - A

01.01.20204Item DLLL00011311311E+08A113113101.01.2020_99909900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

02.01.20202Item BABC1221350035001E+08A13500350002.01.2020_99909900 - A

03.01.20203Item CLLL000410.441.61E+08A410.441.603.01.2020_99909900 - A

04.01.20204Item DLLL00111311318.9E+07F113113104.01.2020_88888888 - F

05.01.20205Item EABC999855044008.9E+07F8550440005.01.2020_88888888 - F

06.01.20206Item FABC9991250025008.9E+07F12500250006.01.2020_888888 88 - F

07.01.20207Item GLLL0011250025008.9E+07F12500250007.01.2020_888888 88 - F

08.01.20208Item HLLL0011225022508.9E+07F12250225008.01.2020_888888 88 - F

09.01.20204Item DABC1231225022508.9E+07F12250225009.01.2020_888888 88 - F

10.01.20205Item EABC1221225022501E+08A12250225010.01.2020_99909900 - A

11.01.202011Item KABC12216006001E+08A160060011.01.2020_99909900 - A

12.01.202012Item LABC1231499249921E+08A14992499212.01.2020_99909900 - A

13.01.202013Item MABC122110101E+08A1101013.01.2020_99909900 - A

14.01.20206Item FLLL0001273127311E+08A12731273114.01.2020_99909900 - A

15.01.20207Item GABC122185000850001E+08A1850008500015.01.2020_9990 9900 - A

01.01.20205Item ELLL000555027501E+08A5550275001.01.2020_99909900 - A

02.01.20202Item BABC1221350035001E+08A13500350002.01.2020_99909900 - A

03.01.20203Item CLLL000410.441.61E+08A410.441.603.01.2020_99909900 - A

04.01.20204Item DLLL00111311318.9E+07F113113104.01.2020_88888888 - F

05.01.20205Item EABC999855044008.9E+07F8550440005.01.2020_88888888 - F

06.01.20206Item FABC9991250025008.9E+07F12500250006.01.2020_888888 88 - F

07.01.20207Item GLLL0011250025008.9E+07F12500250007.01.2020_888888 88 - F

08.01.20208Item HLLL0011225022508.9E+07F12250225008.01.2020_888888 88 - F

09.01.20204Item DABC1231225022508.9E+07F12250225009.01.2020_888888 88 - F

10.01.20205Item EABC1221225022501E+08A12250225010.01.2020_99909900 - A

11.01.202011Item KABC12216006001E+08A160060011.01.2020_99909900 - A

12.01.202012Item LABC1231499249921E+08A14992499212.01.2020_99909900 - A

13.01.202013Item MABC122110101E+08A1101013.01.2020_99909900 - A
Worksheet: arrAllDts

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias






_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )

4567891011121314151622232425262742
Worksheet: arrRws









_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )


4


5


6


7


8


9


10


11


12


13


14


15


16


22


23


24


25


26


27


42
Worksheet: arrRwsT

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias



Option Explicit
Sub DoItForADay()
Rem 1 Worksheets info
Dim WsTp As Worksheet, WsDta As Worksheet, WsSmry As Worksheet
Set WsTp = ThisWorkbook.Worksheets("Template"): Set WsDta = ThisWorkbook.Worksheets("Datadump"): Set WsSmry = ThisWorkbook.Worksheets("Summary")
Rem 2 The days and source list
' 2a) Put all info in an array
Dim LrDta As Long: Let LrDta = WsDta.Range("A" & WsDta.Rows.Count & "").End(xlUp).Row
Dim arrAllDts() As Variant ' In the naxt line, the .Value Property ( method ) , is used to return in one go all Values in the range. They are returned as a field, ( array ) of values in held in Variant type elements. So we must use Variant for the Dim ing of the type of our Elements, or else the next code line will error , with a Mismatch error
Let arrAllDts = WsDta.Range("A4:M" & LrDta & "").Value ' I am adding column M for my own amusement
' 2b)

' 2c) make an array with all unique identifier for each voucher
Dim Cnt As Long
For Cnt = 1 To UBound(arrAllDts(), 1) ' Looping effectively from forth row until last row in Datadump
Dim Idt As String
Let Idt = arrAllDts(Cnt, 1) & "_" & arrAllDts(Cnt, 8) & " - " & arrAllDts(Cnt, 9) ' I am adding a "_" to in between the date and source info : Later I can split the unique identifiers string by this "_" in order to get the date and souce info
Let arrAllDts(Cnt, 13) = Idt
Dim strDtsSrc As String
If InStr(1, strDtsSrc, Idt, vbBinaryCompare) = 0 Then
Let strDtsSrc = strDtsSrc & Idt & "###"
Else
' case we already have the date in our string, strDts
End If
Next Cnt
Let strDtsSrc = Left(strDtsSrc, (Len(strDtsSrc) - 3)) ' take off the last space "###" which we do not need
'Debug.Print strDtsSrc
' 2d)
Dim arrUnicDtsSrc() As String
Let arrUnicDtsSrc() = Split(strDtsSrc, "###", -1)
Let Worksheets("arrUnicDtsSrc").Range("A1").Resize(1, (UBound(arrUnicDtsSrc()) + 1)).Value = arrUnicDtsSrc() ' arrUnicDtsSrc().jpg --- https://imgur.com/QX1bJMB
Worksheets("arrUnicDtsSrc").Columns.AutoFit
Let Worksheets("arrAllDts").Range("A4:M" & LrDta & "").Value = arrAllDts()
' The next code line can be removed to get all the 19 worksheets
ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line, then you will see that all dates and sources will be considered
Rem 3 ' === Main Outer loop ================================================== ==========
Dim Stear As Variant ' For Each unique identifier . In VBA,
For Each Stear In arrUnicDtsSrc() ' Doing stuff For Each unique identifier
'3a) work out how many rows and which row indicies with the current unique identifier
Dim DteSrcRwCnt As Long
For Cnt = 1 To UBound(arrAllDts(), 1) ' ----------------------Going through all data rows
If arrAllDts(Cnt, 13) = CStr(Stear) Then ' I am looking for rows in the main datadump that have the current unique identifier
'3a)(i) counting rows
' Debug.Print Cnt + 3 & " " & arrAllDts(Cnt, 13)
Let DteSrcRwCnt = DteSrcRwCnt + 1 ' counting the rows for the current unique identifier
'3a)(ii) get the (row) indicies for the current unique identifier. Later i need the row number of all the rows corresponding to the current unique identifier
Dim strRws As String
Let strRws = strRws & Cnt + 3 & " " ' I later wont the actual row in the datadump worksheet, so that is 3 higher than the "row" number in arrAllDts() because I captured just the range from the 4th row -- "A4:M........
Else
End If
Next Cnt ' ----------------------Going through all data rows
Let strRws = Left(strRws, (Len(strRws) - 1)) ' Take of last " " which I do not need
Dim arrRws() As String ' The VBA string function returns field of string type elements. So I must Dim my array elements appropriately
Let arrRws() = Split(strRws, " ", -1, vbBinaryCompare) ' This gives us an array which is the row numbers in the Datadump for this unique identifier
Let ThisWorkbook.Worksheets("arrRws").Range("A1").Resize(1, (UBound(arrRws()) + 1)).Value = arrRws() ' arrRws().JPG - https://imgur.com/HDgpyQq -
ThisWorkbook.Worksheets("arrRws").Columns.AutoFit
'3b) In the "Magic Code line" below we need a "vertical" array https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Dim arrRwsT() As Long
ReDim arrRwsT(1 To UBound(arrRws()) + 1, 1 To 1) ' a "Vertical" 1 column array
For Cnt = 1 To UBound(arrRws()) + 1
Let arrRwsT(Cnt, 1) = arrRws(Cnt - 1)
Next Cnt
Let ThisWorkbook.Worksheets("arrRwsT").Range("A1:A" & UBound(arrRws()) + 1 & "").Value = arrRwsT() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Rem 4 Make Vouchers for current unique identifier, Stear
' 4a)
Dim arrVouch() As Variant ' https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Let arrVouch() = WsTp.Range("A1:K24").Value
' 4b) An array just containing the rows for the current Idt
Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:N)") ' {1, 2, 3, 4......14} - Clms().jpg - https://imgur.com/xHlUeH9
Dim arrDtsSrc() As Variant ' For "Magic Code line" https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Let arrDtsSrc() = Application.Index(WsDta.Cells, arrRwsT(), Clms()) ' - --"Magic Code line" - arrDtsSrc().JPG : https://imgur.com/0c8SgIn
Let ThisWorkbook.Worksheets("arrDtsSrc").Range("A1").Resize(UBound(arrDtsSrc(), 1), UBound(arrDtsSrc(), 2)).Value = arrDtsSrc() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Dim RwCnt As Long: Let RwCnt = 1: Let Cnt = 1
' 4c)
Do While RwCnt < DteSrcRwCnt + 1 ' ............................................
Do While Cnt < 11 ' _________________________________|
' Fill in values in Voucher Array
Let arrVouch(Cnt + 9, 1) = "'" & arrDtsSrc(RwCnt, 2) ' The extra "'" is one way to keep the leading 0s
Let arrVouch(Cnt + 9, 4) = arrDtsSrc(RwCnt, 3) ' Detail ( Item )
Let arrVouch(Cnt + 9, 7) = arrDtsSrc(RwCnt, 4) ' Unit Code
Let arrVouch(Cnt + 9, 9) = arrDtsSrc(RwCnt, 11) ' Value
Let Cnt = Cnt + 1
Let RwCnt = RwCnt + 1
Loop ' While Cnt < 11 ' ______________________________|
Let arrVouch(6, 3) = Split(Stear, "_", 2, vbBinaryCompare)(1) ' The second array element (1) is source code & source name ( The first array element (0) is the date )
Let arrVouch(4, 10) = Split(Stear, "_", 2, vbBinaryCompare)(0) ' The first array element (0) is the date
Let Cnt = 1 ' back to first row for a template
'4d) Information to the summary sheet.
Dim NxtVch As Long: Let NxtVch = WsSmry.Range("A" & WsSmry.Rows.Count & "").End(xlUp).Row
Let WsSmry.Range("A" & NxtVch + 1 & "").Value = "V" & Format(NxtVch, "0000")
Let WsSmry.Range("B" & NxtVch + 1 & "").Value = Split(Stear, "_", 2, vbBinaryCompare)(0)
WsSmry.Hyperlinks.Add Anchor:=WsSmry.Range("C" & NxtVch + 1 & ""), Address:="", SubAddress:="V" & Format(NxtVch, "0000") & "!A1", TextToDisplay:="Go To Sheet"
'4e) Add next voucher
WsTp.Copy After:=WsDta
Let ActiveSheet.Name = "V" & Format(NxtVch, "0000")
Let ThisWorkbook.Worksheets("arrVouch").Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Let ActiveSheet.Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch()
Let arrVouch() = WsTp.Range("A1:K24").Value ' get a new template array

Loop ' While RwCnt < DteSrcRwCnt ' .............................................

Let DteSrcRwCnt = 0 ' ready for next Idt Stear
Next Stear ' === Main Outer loop ================================================== =======================

End Sub

[DocAElstein]

In support of this Post:
http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias?p=11847&viewfull=1#post11847


Before
_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1VoucherDateLink


2
Worksheet: Summary





After for first two vouchers
_____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

1VoucherDateLink


2V000101.01.2020Go To Sheet


3V000201.01.2020Go To Sheet


4
Worksheet: Summary





After for all vouchers
Remove this code line

ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line, then you will see that all dates and sources will be considered

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

1VoucherDateLink


2V000101.01.2020Go To Sheet


3V000201.01.2020Go To Sheet


4V000301.01.2020Go To Sheet


5V000401.01.2020Go To Sheet


6V000501.01.2020Go To Sheet


7V000602.01.2020Go To Sheet


8V000703.01.2020Go To Sheet


9V000804.01.2020Go To Sheet


10V000905.01.2020Go To Sheet


11V001006.01.2020Go To Sheet


12V001107.01.2020Go To Sheet


13V001208.01.2020Go To Sheet


14V001309.01.2020Go To Sheet


15V001410.01.2020Go To Sheet


16V001511.01.2020Go To Sheet


17V001612.01.2020Go To Sheet


18V001713.01.2020Go To Sheet


19V001814.01.2020Go To Sheet


20V001915.01.2020Go To Sheet


21
Worksheet: Summary

[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]

Coding in support of this Thread




Option Explicit
' Module scope variable code section
Public Eye As Long
Private Jay As Long
Dim KEh As Long

' Main scheduling macro 1
Sub ByVal_GEhtitsAppObj_1()
1 Application.OnTime Now(), "'CalledByVal Eye, Jay, KEh'"
Let Eye = 11: Let Jay = 12: Let KEh = 13

Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub

' Main scheduling macro 2
Sub ByVal_GEhtitsAppObj_2()
2 Application.OnTime Now(), "'CalledByVal Module1.Eye, Module1.Jay, Module1.KEh'" '_--- Fix _ 2) Module1.MyVariable
Let Eye = 21: Let Jay = 22: Let KEh = 23

Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub

' Main scheduling macro 3
Sub ByRef_GEhtitsAppObj_3()
3 Application.OnTime Now(), "'CalledByRef Eye, Jay, KEh'"
Let Eye = 31: Let Jay = 32: Let KEh = 33

Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub

' Main scheduling macro 4
Sub ByRef_GEhtitsAppObj_4()
4 Application.OnTime Now(), "'CalledByRef Module1.Eye, Module1.Jay, Module1.KEh'" '_--- Fix _ 2) Module1.MyVariable
Let Eye = 41: Let Jay = 42: Let KEh = 43

' Application.OnTime Now(), "'WtchaGotModScopeVariables'" ' ByRef is not working if this is done
Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'" '_--- Fix _ 1) to get ByRef to work
End Sub

Sub WtchaGotModScopeVariables()
Debug.Print Eye & " " & Jay & " " & KEh & vbCr & vbLf
End Sub





Sub CalledByVal(ByVal I As Long, ByVal J As Long, ByVal K As Long)
Debug.Print I & " " & J & " " & K
Let I = I + 1000: Let J = J + 1000: Let K = K + 1000
End Sub
Sub CalledByRef(ByRef I As Long, ByRef J As Long, ByRef K As Long)
Debug.Print I & " " & J & " " & K
Let I = I + 2000: Let J = J + 2000: Let K = K + 2000
End Sub



'Results
' Macro 1
' 11 0 0
' 11 12 13
'
' Macro 2
' 21 22 23
' 21 22 23
'
' Macro 3
'
' Fail!!!!!
'
'
' Macro 4
' 41 42 43
' 2041 2042 2043
'
'
'
'
'
'
'
'
'











































































































'
'
'
'
'
'
'
'
'
'
'

Sub GEhtitsAppObject()
1
2 Rem 1 Simple use of variables
Let Eye = 31: Let Jay = 32: Let KEh = 33
3 Debug.Print Eye & " " & Jay & " " & KEh
Let Eye = 41: Let Jay = 42: Let KEh = 43
4 Debug.Print Module1.Eye & " " & Module1.Jay & " " & Module1.KEh
5
6 Rem 2 Call ing Subs with variable arguments
Let Eye = 71: Let Jay = 72: Let KEh = 73
7 Call CalledByVal(Eye, Jay, KEh)
Let Eye = 81: Let Jay = 82: Let KEh = 83
8 Call CalledByVal(Module1.Eye, Module1.Jay, Module1.KEh)
9
Let Eye = 101: Let Jay = 102: Let KEh = 103
10 Call CalledByRef(Eye, Jay, KEh)
Let Eye = 111: Let Jay = 112: Let KEh = 113
11 Call CalledByRef(Module1.Eye, Module1.Jay, Module1.KEh)
12
13 Rem 3 Application.OnTime
Let Eye = 141: Let Jay = 142: Let KEh = 143
14 Application.OnTime Now(), "'CalledByVal Module1.Eye, Module1.Jay, Module1.KEh'"
Let Eye = 151: Let Jay = 152: Let KEh = 153
15 Application.OnTime Now(), "'CalledByVal Eye, Jay, KEh'"
16
Let Eye = 171: Let Jay = 172: Let KEh = 173
17 'Application.OnTime Now(), "'CalledByRef Eye, Jay, KEh'"
Let Eye = 181: Let Jay = 182: Let KEh = 183
18 Application.OnTime Now(), "'CalledByRef Module1.Eye, Module1.Jay, Module1.KEh'"
19
End Sub







'20 Rem 4 Application.Run
' Let Eye = 211: Let Jay = 212: Let KEh = 213
'21 Application.Run "CalledByVal", Eye, Jay, KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
' Let Eye = 221: Let Jay = 222: Let KEh = 223
'22 Application.Run "CalledByVal", Module1.Eye, Module1.Jay, Module1.KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'23
'
' Let Eye = 241: Let Jay = 242: Let KEh = 243
'24 Application.Run "CalledByRef", Module1.Eye, Module1.Jay, Module1.KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
' Let Eye = 251: Let Jay = 252: Let KEh = 253
'25 Application.Run "CalledByRef", Eye, Jay, KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
'End Sub
' Sub CalledByVal(ByVal I As Long, ByVal J As Long, ByVal K As Long)
' Debug.Print I & " " & J & " " & K
' Let I = I + 1000: Let J = J + 1000: Let K = K + 1000
' End Sub
' Sub CalledByRef(ByRef I As Long, ByRef J As Long, ByRef K As Long)
' Debug.Print I & " " & J & " " & K
' Let I = I + 2000: Let J = J + 2000: Let K = K + 2000
' End Sub

[DocAElstein]

In support of this thread
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12138&viewfull=1#post12138



dism.exe /Online /Get-Drivers > "C:\Users\Elston\Desktop\3rdparty driverlist.txt"


Tool zur Imageverwaltung fr die Bereitstellung
Version: 10.0.17134.1

Abbildversion: 10.0.17134.1246

Liste der Treiber von Drittanbietern wird aus dem Treiberspeicher abgerufen...

Treiberpaketauflistung:

Ver"ffentlichter Name : oem0.inf
Originaldateiname : prnms009.inf
Windows-intern : Nein
Klassenname : Printer
Anbietername : Microsoft
Datum : 21.06.2006
Version : 10.0.17134.1

Ver"ffentlichter Name : oem1.inf
Originaldateiname : prnms001.inf
Windows-intern : Nein
Klassenname : Printer
Anbietername : Microsoft
Datum : 21.06.2006
Version : 10.0.17134.1

Ver"ffentlichter Name : oem2.inf
Originaldateiname : igdlh.inf
Windows-intern : Nein
Klassenname : Display
Anbietername : Intel Corporation
Datum : 11.03.2013
Version : 8.15.10.2702

Ver"ffentlichter Name : oem3.inf
Originaldateiname : hpygid20_v4.inf
Windows-intern : Nein
Klassenname : Printer
Anbietername : HP
Datum : 29.05.2017
Version : 20.79.1.6692

Der Vorgang wurde erfolgreich beendet.





dism /online /export-driver /destination: "C:\Users\Elston\Desktop\driverbackupBefore"
Export-WindowsDriver -Online -Destination "C:\Users\MeinPC\Desktop\PowerShell driverbackup"



_____ Workbook: wbCodesBeforeFrom cmd prompt.xlsm ( Using Excel 2007 32 bit )

F:\Windows\Windows 10\Win 10 Devices\driverbackupdriverbackup



F:\Windows\Windows 10\Win 10 Devices\driverbackup\hpygid20_v4.inf_amd64_01bab60 e80914ef1hpygid20_v4.inf_amd64_01bab60e80914ef1

hp8720.bag

hpgid20v4-bidiEvent.xml

hpgid20v4-bidiSPM.xml

hpgid20v4-bidiUSB-OPA.xml

hpgid20v4-bidiUSB.js

hpgid20v4-bidiWSD.xml

hpgid20v4-constraints.js

hpgid20v4-PipelineConfig.xml

hpgid20v4cfg.gdl

hpgid20v4help.cab

hpgid20v4map.xml

hpgid20v4que.xml

hpygid20_8720-manifest.ini

hpygid20_v4.cat

hpygid20_v4.inf

hpygid20_v4.PNF



F:\Windows\Windows 10\Win 10 Devices\driverbackup\hpygid20_v4.inf_amd64_01bab60 e80914ef1\amd64amd64

hpbxpsv420.dll

hpgid20v4PE.exe

hpgid20v4PELib.dll

hpgid20v4_symbols.gpd

hpoj_8720_v4.gpd

hpUIMDDialog20.dll

hpygiddrv20.dll

hpygidres20.dll

userfors.dll



F:\Windows\Windows 10\Win 10 Devices\driverbackup\igdlh.inf_amd64_c9077a4bbb395 caaigdlh.inf_amd64_c9077a4bbb395caa

igcompkrng500.bin

igd10umd32.dll

igd10umd64.dll

igdkmd64.sys

igdlh.cat

igdlh.inf

igdlh.PNF

igdumd32.dll

igdumd64.dll

igfcg500m.bin

igkrng500.bin

iglhcp32.dll

iglhcp64.dll

iglhsip32.dll

iglhsip64.dll

iglhxa64.cpa

iglhxa64.vp

iglhxc64.vp

iglhxg64.vp

iglhxo64.vp

iglhxs64.vp



F:\Windows\Windows 10\Win 10 Devices\driverbackup\prnms001.inf_amd64_cb0feabdd7 1f0e97prnms001.inf_amd64_cb0feabdd71f0e97

MXDW-manifest.ini

MXDW-pipelineconfig.xml

MXDW.gpd

mxdwdui.dll

prnms001.cat

prnms001.Inf

prnms001.PNF



F:\Windows\Windows 10\Win 10 Devices\driverbackup\prnms009.inf_amd64_5887f9f923 285dd6prnms009.inf_amd64_5887f9f923285dd6

MPDW-constraints.js

MPDW-manifest.ini

MPDW-PDC.xml

MPDW-pipelineconfig.xml

MPDW_devmode_map.xml

prnms009.cat

prnms009.Inf

prnms009.PNF
Worksheet: cmd

[DocAElstein]

In support of this Post:
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12124&viewfull=1#post12124

_____ Workbook: wbCodesBeforeFrom cmd prompt.xlsm ( Using Excel 2007 32 bit )



Audio, Video und Gamecontroller

High definition Audio-Gerät













High definition Audio-Gerät













Audioeingänge und - ausgänge

47PL3605h(High definition Audio-Gerät



Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)



Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)



Computer

ACIPx64-basierter PC



Druckwarteshlangen

Fax



Micrtosoft print to PDF



Microsoft XPS Document Writer



OneNote



Stammdruckwarteshlange



DVD/CD-ROM-Laufwerke

TSSTcorpDVD-ROM SH-D163C ATA Device



Eingabegeräte (Human Interface Device)

HID-Konformer Sysgtemcontroller



HID-Konformer Benutzersteuergeräte



HID-Konformer vom Hersteller definiertes Gerät



HID-Konformer vom Hersteller definiertes Gerät



USB-Eingabegerät







USB-Eingabegerät







Grafikkarten

Intel(R) G41 Express Chipset (Microsoft Corporation - WDDM 1.1)











































IDE ATA/ATAPI-Controller

ATA Channel 0







ATA Chanel 1







Intel(R) 82801GB/GR/GH(ICH7 Familie) Serieller ATA-Speichercomtroller - 27C0









IEEE 1394-Hostcontroller

OHCI-konformer texas Instruments1394-Hostcontroller



Laufwerk

General UDisk USB Device







SAMSUNG HD253GJ ATA Device







Mäuse und andere Zeigegeräte

HID-konforme Mause





Monitore

PnP-Monitore (Standard)



Netzwerkadaptor

Realitek PCIe GBE Family Controller



WAN Miniport (IKEv2)



WAN Miniport (IP)





WAN Miniport (IPv6)





WAN Miniport (L2DP)



WAN Miniport (Network Monitor)





WAN Miniport (PPPOE)



WAN Miniport (PPTP)



WAN Miniport (SSTP)



Prozessoren

Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz



Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz



Softwaregeräte

Brother DCP-1610W series [e89eb44818d]



ELSTON-PC: elston:



HPB6102A (HP Officejet Pro 8720)



Microsoft Device Asssociation Root Enumerator



Microsoft GS Wavetable Synthesis



Microsoft RRAS Root Enumerator



NPIA27BB4 (HP Laserjet 200 colorMFP M275nw)



Speichercontroller

Microsoft-Controller für Speicherplätze





Systemgeräte


1ACIP-Schalter




2Busenumerator für Verbundgeräte

compositebus.inf_amd64_bcb89b3386563bd7\CompositeB us.sys


3CPU-zu-EA-Controller




4DMA-Controller




5Enumerator für virtuelle NDIS-Nertzwerkadaptor




6High Definition Audio Controller










7Hochpräzisionsereigniszeitgeber




8Legacygerät




9LPC-Controller




10Microsoft ACPI-Konformers System




11Microsoft virtueller Datenträgerenumerator




12Microsoft-Systemverwaltungs-BIOS-Treiber




13Numerischer Coprozessor




14PCI-Bus




15PCI-zu-PCI-Brücke




16PCI-zu-PCI-Brücke




17PCI-zu-PCI-Brücke




18PnP-Softwaregeräte-Enumerator

swenum.inf_amd64_ea7b19c04e7a8136\swenum.sys


19Programmierbarer Interruptcontroller




20Redirector-Bus für Remotedesktop-Geräte




21SM-Bus-Controller




22Systrem CMOS/Echtzeituhr




23Systemlautsprecher




24Systemzeitgeber




25UMBus-Stamm-Busenumerator



Tastaturen

HID-Tastatur





Tragbare Geräte

USB_China2







USB-Controller


1Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CB








2Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C9








3Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CA








4Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C8








5Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CC








6USB-Massenspeichergeräte




7USB-Root-Hub






8USB-Root-Hub






9USB-Root-Hub






10USB-Root-Hub






11USB-Root-Hub






12USB-Verbundgeräte


Worksheet: Manual



wbCodesBeforeFrom cmd prompt.xlsm : https://app.box.com/s/hix9sjernnbdu9vk2oqgspg8z00t9u8j

[DocAElstein]

_____ Workbook: wbCodesBeforeFrom cmd prompt.xlsm ( Using Excel 2007 32 bit )

C:\Windows\system32\DRIVERS\dmk.sys

C:\Windows\system32\DRIVERS\HdAudio.sys

C:\Windows\system32\drivers\ksthunk.sys

C:\Windows\system32\DRIVERS\portcls.sys

C:\Windows\system32\SysFxUl.dll

C:\Windows\system32\WMALFXGFXDSP.dll



C:\Windows\system32\DRIVERS\dmk.sys

C:\Windows\system32\DRIVERS\HdAudio.sys

C:\Windows\system32\drivers\ksthunk.sys

C:\Windows\system32\DRIVERS\portcls.sys

C:\Windows\system32\SysFxUl.dll

C:\Windows\system32\WMALFXGFXDSP.dll















































C:\Windows\system32\DRIVERS\cdrom.sys





















C:\Windows\system32\DRIVERS\hidclass.sys

C:\Windows\system32\DRIVERS\hidparse.sys

C:\Windows\system32\DRIVERS\hidusb.sys



C:\Windows\system32\DRIVERS\hidclass.sys

C:\Windows\system32\DRIVERS\hidparse.sys

C:\Windows\system32\DRIVERS\hidusb.sys





C:\Windows\system32\DRIVERS\igdkmd64.sys

C:\Windows\system32\igcompkmg500.bin

C:\Windows\system32\igd10umd64.dll

C:\Windows\system32\igdumd64.dll

C:\Windows\system32\igfcg500m.bin

C:\Windows\system32\igkmg500.bin

C:\Windows\system32\iglhcp64.dll

C:\Windows\system32\iglhsip64.dl

C:\Windows\system32\iglhxa64.cpa

C:\Windows\system32\iglhxa64.vp

C:\Windows\system32\iglhxc64.vp

C:\Windows\system32\iglhxg64.vp

C:\Windows\system32\iglhxo64.vp

C:\Windows\system32\iglhxs64.vp

C:\Windows\SysWow64\igcompkmg500.bin

C:\Windows\SysWow64\igd10umd32.dll

C:\Windows\SysWow64\igdumd32.dll

C:\Windows\SysWow64\igfcg500m.bin

C:\Windows\SysWow64\igkmg500.bin

C:\Windows\SysWow64\iglhcp32.dll

C:\Windows\SysWow64\iglhsip32.dll





C:\Windows\system32\DRIVERS\atapi.sys

C:\Windows\system32\DRIVERS\ataport.sys





C:\Windows\system32\DRIVERS\atapi.sys

C:\Windows\system32\DRIVERS\ataport.sys





C:\Windows\system32\DRIVERS\atapi.sys

C:\Windows\system32\DRIVERS\ataport.sys

C:\Windows\system32\DRIVERS\intelide.sys

C:\Windows\system32\DRIVERS\pciidx.sys





C:\Windows\system32\DRIVERS\1394ohci.sys





C:\Windows\system32\DRIVERS\disk.sys

C:\Windows\system32\DRIVERS\EhStorClass.sys

C:\Windows\system32\DRIVERS\partmgr.sys



C:\Windows\system32\DRIVERS\disk.sys

C:\Windows\system32\drivers\EhStorClass.sys

C:\Windows\system32\drivers\partmgr.sys





C:\Windows\system32\DRIVERS\mouclass.sys

C:\Windows\system32\DRIVERS\mouhid.sys





C:\Windows\system32\DRIVERS\monitor.sys





C:\Windows\system32\DRIVERS\rt640x64.sys



C:\Windows\system32\drivers\AgileVpn.sys



C:\Windows\system32\DRIVERS\ndistapi.sys

C:\Windows\system32\DRIVERS\ndiswan.sys



C:\Windows\system32\DRIVERS\ndistapi.sys

C:\Windows\system32\DRIVERS\ndiswan.sys



C:\Windows\system32\DRIVERS\rasl2tp.sys



C:\Windows\system32\DRIVERS\ndistapi.sys

C:\Windows\system32\DRIVERS\ndiswan.sys



C:\Windows\system32\DRIVERS\rasppppoe.sys



C:\Windows\system32\drivers\raspptp.swys



C:\Windows\system32\DRIVERS\rassstptp.sys





C:\Windows\system32\DRIVERS\intelppm.sys



C:\Windows\system32\DRIVERS\intelppm.sys



































C:\Windows\system32\DRIVERS\spacedump.sys

C:\Windows\system32\DRIVERS\spaceport.sys





















C:\Windows\system32\drivers\NdisVirtualBus.sys





C:\Windows\system32\DRIVERS\dmk.sys

C:\Windows\system32\DRIVERS\hdaudbus.sys

C:\Windows\system32\DRIVERS\portcls.sys











C:\Windows\system32\DRIVERS\msisadrv.sys



C:\Windows\system32\DRIVERS\acpi.sys



C:\Windows\system32\DRIVERS\vdrvroot.sys



C:\Windows\system32\DRIVERS\mssmbios.sys







C:\Windows\system32\DRIVERS\pci.sys



C:\Windows\system32\DRIVERS\pci.sys



C:\Windows\system32\DRIVERS\pci.sys



C:\Windows\system32\DRIVERS\pci.sys











C:\Windows\system32\DRIVERS\rdpbus.sys



















C:\Windows\system32\DRIVERS\umbus.sys





C:\Windows\system32\DRIVERS\kbdclass.sys

C:\Windows\system32\DRIVERS\kbdhid.sys





C:\Windows\system32\DRIVERS\UMDF\WpdFs.dll

C:\Windows\system32\drivers\WpdUpFltr.sys

C:\Windows\system32\DRIVERS\WUDFRd.sys





C:\Windows\system32\drivers\usbhub.sys

C:\Windows\system32\drivers\usbport.sys

C:\Windows\system32\drivers\usbuhci.sys



C:\Windows\system32\drivers\usbhub.sys

C:\Windows\system32\drivers\usbport.sys

C:\Windows\system32\drivers\usbuhci.sys



C:\Windows\system32\drivers\usbhub.sys

C:\Windows\system32\drivers\usbport.sys

C:\Windows\system32\drivers\usbuhci.sys



C:\Windows\system32\drivers\usbhub.sys

C:\Windows\system32\drivers\usbport.sys

C:\Windows\system32\drivers\usbuhci.sys



C:\Windows\system32\drivers\usbehci.sys

C:\Windows\system32\drivers\usbhub.sys

C:\Windows\system32\drivers\usbport.sys



C:\Windows\system32\drivers\USBSTOR.SYS



C:\Windows\system32\drivers\usbd.sys

C:\Windows\system32\drivers\usbhub.sys



C:\Windows\system32\drivers\usbd.sys

C:\Windows\system32\drivers\usbhub.sys



C:\Windows\system32\drivers\usbd.sys

C:\Windows\system32\drivers\usbhub.sys



C:\Windows\system32\drivers\usbd.sys

C:\Windows\system32\drivers\usbhub.sys



C:\Windows\system32\drivers\usbd.sys

C:\Windows\system32\drivers\usbhub.sys



C:\Windows\system32\drivers\usbccgp.sys
Worksheet: Manual

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12124&viewfull=1#post12124







Geräte-Manager Before : https://imgur.com/6IT2NC9
2722
https://i.imgur.com/6IT2NC9.jpg



Audio Video und Game Controler 1.JPG : https://imgur.com/pxfQIX9
Audio Video und Game Controler 2.JPG : https://imgur.com/iUPViMn
Audioeingänge und -ausgänge 1.JPG : https://imgur.com/flkUEWD
Audioeingänge und -ausgänge 3.JPG : https://imgur.com/qnYMTjP
Audioeingänge und -ausgänge 2.JPG : https://imgur.com/ILJ1kBf
Computer.JPG : https://imgur.com/NuodN0E
Druckwarteshlange Fax.JPG : https://imgur.com/Uch955O
Druckwarteshlange Microsoft Print to PDF.JPG : https://imgur.com/KGTW8wq
Druckwarteshlange Microsoft XPS Document Writer.JPG : https://imgur.com/lRLmhZO
Druckwarteshlange OneNote.JPG : https://imgur.com/bjLMcGM
Druckwarteshlange Stammdruckwarteshlange.JPG : https://imgur.com/1Ndf2XB
DVD CD-ROM-Laufwerke.JPG : https://imgur.com/daGiajr
Eingabegeräte (Human Interface Decice) 1.JPG : https://imgur.com/GVQjnNv
Eingabegeräte (Human Interface Decice) 2.JPG : https://imgur.com/Fzeu0pS
Eingabegeräte (Human Interface Decice) 3.JPG : https://imgur.com/4TtEjHU
Eingabegeräte (Human Interface Decice) 4.JPG : https://imgur.com/Ng3DVE3
Eingabegeräte (Human Interface Decice) 5.JPG : https://imgur.com/wbFK11u
Eingabegeräte (Human Interface Decice) 6.JPG : https://imgur.com/DbSdltZ
Grafikkarten.JPG : https://imgur.com/dW6OOrI
IDE ATA ATAPI-Controller 1.JPG : https://imgur.com/1rVKfbC
IDE ATA ATAPI-Controller 2.JPG : https://imgur.com/2YI9jdL
IDE ATA ATAPI-Controller 3.JPG : https://imgur.com/L6HbNp4
IEE 1394-Hostcontroller.JPG : https://imgur.com/IwO5pbG
Laufwerk 1.JPG : https://imgur.com/8KyZRiK
Laufwerk 2.JPG : https://imgur.com/eDvgnMH
Mäuse und andere Zeigegeräte.JPG : https://imgur.com/XFl9PcA
Monitore.JPG : https://imgur.com/VAayLlT
Netzwerkadaptor 1.JPG : https://imgur.com/2NiovPn
Netzwerkadaptor 2.JPG : https://imgur.com/xP80QlV
Netzwerkadaptor 3.JPG : https://imgur.com/IpFWH0x
Netzwerkadaptor 4.JPG : https://imgur.com/8pVcZ8M
Netzwerkadaptor 5.JPG : https://imgur.com/S3W35Z3
Netzwerkadaptor 6.JPG : https://imgur.com/lUZDGcP
Netzwerkadaptor 7.JPG : https://imgur.com/dBFnOFD
Netzwerkadaptor 8.JPG : https://imgur.com/rnxwMoN
Netzwerkadaptor 9.JPG : https://imgur.com/WQYsDDk
Prozessoren 1.JPG : https://imgur.com/9B7pMqH
Prozessoren 2.JPG : https://imgur.com/mvfLvOG
Softwaregeräte 1.JPG : https://imgur.com/us8XDDQ
Softwaregeräte 2.JPG : https://imgur.com/q15BRkP
Softwaregeräte 3.JPG : https://imgur.com/AdDBMaz
Softwaregeräte 4.JPG : https://imgur.com/Xswu3mW
Softwaregeräte 5.JPG : https://imgur.com/8YiYQFL
Softwaregeräte 6.JPG : https://imgur.com/RcxBE0o
Softwaregeräte 7.JPG : https://imgur.com/lvXaM9Z
Speichercontroller.JPG : https://imgur.com/IZcPqew
Systemgeräte 1.JPG : https://imgur.com/axWbdSx
Systemgeräte 2.JPG : https://imgur.com/wArJPoq
Systemgeräte 3.JPG : https://imgur.com/i778VGg
Systemgeräte 4.JPG : https://imgur.com/khBWz5F
Systemgeräte 5.JPG : https://imgur.com/sRNIUqw
Systemgeräte 6.JPG : https://imgur.com/gXmMoyM
Systemgeräte 7.JPG : https://imgur.com/TzOrMQb
Systemgeräte 8.JPG : https://imgur.com/CJecHST
Systemgeräte 9.JPG : https://imgur.com/FwH9rrd
Systemgeräte 10.JPG : https://imgur.com/urqGHV8
Systemgeräte 11.JPG : https://imgur.com/Y11hbdk
Systemgeräte 12.JPG : https://imgur.com/ULwFr7T
Systemgeräte 13.JPG : https://imgur.com/218r0g0
Systemgeräte 14.JPG : https://imgur.com/Nr8O15k
Systemgeräte 15.JPG : https://imgur.com/o9sMnlQ
Systemgeräte 16.JPG : https://imgur.com/B7PRKDp
Systemgeräte 17.JPG : https://imgur.com/MMkwaen
Systemgeräte 18.JPG : https://imgur.com/6gE2Afq
Systemgeräte 19.JPG : https://imgur.com/Y7UcvGE
Systemgeräte 20.JPG : https://imgur.com/dVtp9FW
Systemgeräte 21.JPG : https://imgur.com/NHk0epf
Systemgeräte 22.JPG : https://imgur.com/wUN3To1
Systemgeräte 23.JPG : https://imgur.com/uJg3OMi
Systemgeräte 24.JPG : https://imgur.com/9MpF7nk
Systemgeräte 25.JPG : https://imgur.com/cZ4x8Jf
Tastaturen.JPG : https://imgur.com/2eGpdYE
Tragbare Geräte.JPG : https://imgur.com/sLjH1UH
USB-Controller 1.JPG : https://imgur.com/0LtyydZ
USB-Controller 2.JPG : https://imgur.com/ZBkmxaS
USB-Controller 3.JPG : https://imgur.com/ToQj8d8
USB-Controller 4.JPG : https://imgur.com/rGFUyhA
USB-Controller 5.JPG : https://imgur.com/bSYZSOM
USB-Controller 6.JPG : https://imgur.com/w7wk6G5
USB-Controller 7.JPG : https://imgur.com/eGPgFxa
USB-Controller 8.JPG : https://imgur.com/XAEXWmk
USB-Controller 9.JPG : https://imgur.com/GV2mhmg
USB-Controller 10.JPG : https://imgur.com/a3j29CH
USB-Controller 11.JPG : https://imgur.com/KykO1mb


Device Manager Before.JPG : https://imgur.com/DfI49fZ
Geraete Manager Before.xlsm : https://app.box.com/s/sef9l9cr9df7ul7i22cno49uqcqecte0


















wbCodesBeforeFrom cmd prompt.xlsm : https://app.box.com/s/hix9sjernnbdu9vk2oqgspg8z00t9u8j

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12124&viewfull=1#post12124







Geräte-Manager Before : https://imgur.com/6IT2NC9
2722
https://i.imgur.com/6IT2NC9.jpg





Audio, Video und Gamecontroller
High definition Audio-Gerät
C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\HdAudio.sys
C:\Windows\system32\drivers\ksthunk.sys
C:\Windows\system32\DRIVERS\portcls.sys
C:\Windows\system32\SysFxUl.dll
C:\Windows\system32\WMALFXGFXDSP.dll
High definition Audio-Gerät
C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\HdAudio.sys
C:\Windows\system32\drivers\ksthunk.sys
C:\Windows\system32\DRIVERS\portcls.sys
C:\Windows\system32\SysFxUl.dll
C:\Windows\system32\WMALFXGFXDSP.dll
Audioeingänge und - ausgänge
47PL3605h(High definition Audio-Gerät

Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)

Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)

Computer
ACIPx64-basierter PC

Druckwarteshlangen
Fax

Micrtosoft print to PDF

Microsoft XPS Document Writer

OneNote

Stammdruckwarteshlange

DVD/CD-ROM-Laufwerke
TSSTcorpDVD-ROM SH-D163C ATA Device
C:\Windows\system32\DRIVERS\cdrom.sys
Eingabegeräte (Human Interface Device)
HID-Konformer Sysgtemcontroller

HID-Konformer Benutzersteuergeräte

HID-Konformer vom Hersteller definiertes Gerät

HID-Konformer vom Hersteller definiertes Gerät

USB-Eingabegerät
C:\Windows\system32\DRIVERS\hidclass.sys
C:\Windows\system32\DRIVERS\hidparse.sys
C:\Windows\system32\DRIVERS\hidusb.sys
USB-Eingabegerät
C:\Windows\system32\DRIVERS\hidclass.sys
C:\Windows\system32\DRIVERS\hidparse.sys
C:\Windows\system32\DRIVERS\hidusb.sys
Grafikkarten
Intel(R) G41 Express Chipset (Microsoft Corporation - WDDM 1.1)
C:\Windows\system32\DRIVERS\igdkmd64.sys
C:\Windows\system32\igcompkmg500.bin
C:\Windows\system32\igd10umd64.dll
C:\Windows\system32\igdumd64.dll
C:\Windows\system32\igfcg500m.bin
C:\Windows\system32\igkmg500.bin
C:\Windows\system32\iglhcp64.dll
C:\Windows\system32\iglhsip64.dl
C:\Windows\system32\iglhxa64.cpa
C:\Windows\system32\iglhxa64.vp
C:\Windows\system32\iglhxc64.vp
C:\Windows\system32\iglhxg64.vp
C:\Windows\system32\iglhxo64.vp
C:\Windows\system32\iglhxs64.vp
C:\Windows\SysWow64\igcompkmg500.bin
C:\Windows\SysWow64\igd10umd32.dll
C:\Windows\SysWow64\igdumd32.dll
C:\Windows\SysWow64\igfcg500m.bin
C:\Windows\SysWow64\igkmg500.bin
C:\Windows\SysWow64\iglhcp32.dll
C:\Windows\SysWow64\iglhsip32.dll
IDE ATA/ATAPI-Controller
ATA Channel 0
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys

ATA Chanel 1
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys

Intel(R) 82801GB/GR/GH(ICH7 Familie) Serieller ATA-Speichercomtroller - 27C0
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys
C:\Windows\system32\DRIVERS\intelide.sys
C:\Windows\system32\DRIVERS\pciidx.sys
IEEE 1394-Hostcontroller
OHCI-konformer texas Instruments1394-Hostcontroller
C:\Windows\system32\DRIVERS\1394ohci.sys
Laufwerk
General UDisk USB Device
C:\Windows\system32\DRIVERS\disk.sys
C:\Windows\system32\DRIVERS\EhStorClass.sys
C:\Windows\system32\DRIVERS\partmgr.sys
SAMSUNG HD253GJ ATA Device
C:\Windows\system32\DRIVERS\disk.sys
C:\Windows\system32\drivers\EhStorClass.sys
C:\Windows\system32\drivers\partmgr.sys
Mäuse und andere Zeigegeräte
HID-konforme Mause
C:\Windows\system32\DRIVERS\mouclass.sys
C:\Windows\system32\DRIVERS\mouhid.sys
Monitore
PnP-Monitore (Standard)
C:\Windows\system32\DRIVERS\monitor.sys
Netzwerkadaptor
Realitek PCIe GBE Family Controller
C:\Windows\system32\DRIVERS\rt640x64.sys
WAN Miniport (IKEv2)
C:\Windows\system32\drivers\AgileVpn.sys
WAN Miniport (IP)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (IPv6)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (L2DP)
C:\Windows\system32\DRIVERS\rasl2tp.sys
WAN Miniport (Network Monitor)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (PPPOE)
C:\Windows\system32\DRIVERS\rasppppoe.sys
WAN Miniport (PPTP)
C:\Windows\system32\drivers\raspptp.swys
WAN Miniport (SSTP)
C:\Windows\system32\DRIVERS\rassstptp.sys
Prozessoren
Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz
C:\Windows\system32\DRIVERS\intelppm.sys
Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz
C:\Windows\system32\DRIVERS\intelppm.sys
Softwaregeräte
Brother DCP-1610W series [e89eb44818d]

ELSTON-PC: elston:

HPB6102A (HP Officejet Pro 8720)

Microsoft Device Asssociation Root Enumerator

Microsoft GS Wavetable Synthesis

Microsoft RRAS Root Enumerator

NPIA27BB4 (HP Laserjet 200 colorMFP M275nw)

Speichercontroller
Microsoft-Controller für Speicherplätze
C:\Windows\system32\DRIVERS\spacedump.sys
C:\Windows\system32\DRIVERS\spaceport.sys
Systemgeräte
1 ACIP-Schalter

2 Busenumerator für Verbundgeräte
compositebus.inf_amd64_bcb89b3386563bd7\CompositeB us.sys
3 CPU-zu-EA-Controller

4 DMA-Controller

5 Enumerator für virtuelle NDIS-Nertzwerkadaptor
C:\Windows\system32\drivers\NdisVirtualBus.sys
6 High Definition Audio Controller

C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\hdaudbus.sys
C:\Windows\system32\DRIVERS\portcls.sys
7 Hochpräzisionsereigniszeitgeber

8 Legacygerät

9 LPC-Controller
C:\Windows\system32\DRIVERS\msisadrv.sys
10 Microsoft ACPI-Konformers System
C:\Windows\system32\DRIVERS\acpi.sys
11 Microsoft virtueller Datenträgerenumerator
C:\Windows\system32\DRIVERS\vdrvroot.sys
12 Microsoft-Systemverwaltungs-BIOS-Treiber
C:\Windows\system32\DRIVERS\mssmbios.sys
13 Numerischer Coprozessor

14 PCI-Bus
C:\Windows\system32\DRIVERS\pci.sys
15 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
16 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
17 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
18 PnP-Softwaregeräte-Enumerator
swenum.inf_amd64_ea7b19c04e7a8136\swenum.sys
19 Programmierbarer Interruptcontroller

20 Redirector-Bus für Remotedesktop-Geräte
C:\Windows\system32\DRIVERS\rdpbus.sys
21 SM-Bus-Controller

22 Systrem CMOS/Echtzeituhr

23 Systemlautsprecher

24 Systemzeitgeber

25 UMBus-Stamm-Busenumerator
C:\Windows\system32\DRIVERS\umbus.sys
Tastaturen
HID-Tastatur
C:\Windows\system32\DRIVERS\kbdclass.sys
C:\Windows\system32\DRIVERS\kbdhid.sys
Tragbare Geräte
USB_China2
C:\Windows\system32\DRIVERS\UMDF\WpdFs.dll
C:\Windows\system32\drivers\WpdUpFltr.sys
C:\Windows\system32\DRIVERS\WUDFRd.sys
USB-Controller
1 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CB
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
2 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C9
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
3 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CA
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
4 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C8
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
5 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CC
C:\Windows\system32\drivers\usbehci.sys
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
6 USB-Massenspeichergeräte
C:\Windows\system32\drivers\USBSTOR.SYS
7 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
8 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
9 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
10 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
11 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
12 USB-Verbundgeräte
C:\Windows\system32\drivers\usbccgp.sys







120




Device Manager Before.JPG : https://imgur.com/DfI49fZ
Geraete Manager Before.xlsm : https://app.box.com/s/sef9l9cr9df7ul7i22cno49uqcqecte0


















wbCodesBeforeFrom cmd prompt.xlsm : https://app.box.com/s/hix9sjernnbdu9vk2oqgspg8z00t9u8j

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12124&viewfull=1#post12124



Geräte-Manager Before : https://imgur.com/6IT2NC9
2722
https://i.imgur.com/6IT2NC9.jpg






Audio, Video und Gamecontroller
High definition Audio-Gerät
C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\HdAudio.sys
C:\Windows\system32\drivers\ksthunk.sys
C:\Windows\system32\DRIVERS\portcls.sys
C:\Windows\system32\SysFxUl.dll
C:\Windows\system32\WMALFXGFXDSP.dll
High definition Audio-Gerät
C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\HdAudio.sys
C:\Windows\system32\drivers\ksthunk.sys
C:\Windows\system32\DRIVERS\portcls.sys
C:\Windows\system32\SysFxUl.dll
C:\Windows\system32\WMALFXGFXDSP.dll
Audioeingänge und - ausgänge
47PL3605h(High definition Audio-Gerät

Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)

Digitalaudio (S/PDIF) (2 - High Definition Audio.Gerät)

Computer
ACIPx64-basierter PC

Druckwarteshlangen
Fax

Micrtosoft print to PDF

Microsoft XPS Document Writer

OneNote

Stammdruckwarteshlange

DVD/CD-ROM-Laufwerke
TSSTcorpDVD-ROM SH-D163C ATA Device
C:\Windows\system32\DRIVERS\cdrom.sys
Eingabegeräte (Human Interface Device)
HID-Konformer Sysgtemcontroller

HID-Konformer Benutzersteuergeräte

HID-Konformer vom Hersteller definiertes Gerät

HID-Konformer vom Hersteller definiertes Gerät

USB-Eingabegerät
C:\Windows\system32\DRIVERS\hidclass.sys
C:\Windows\system32\DRIVERS\hidparse.sys
C:\Windows\system32\DRIVERS\hidusb.sys
USB-Eingabegerät
C:\Windows\system32\DRIVERS\hidclass.sys
C:\Windows\system32\DRIVERS\hidparse.sys
C:\Windows\system32\DRIVERS\hidusb.sys
Grafikkarten
Intel(R) G41 Express Chipset (Microsoft Corporation - WDDM 1.1)
C:\Windows\system32\DRIVERS\igdkmd64.sys
C:\Windows\system32\igcompkmg500.bin
C:\Windows\system32\igd10umd64.dll
C:\Windows\system32\igdumd64.dll
C:\Windows\system32\igfcg500m.bin
C:\Windows\system32\igkmg500.bin
C:\Windows\system32\iglhcp64.dll
C:\Windows\system32\iglhsip64.dl
C:\Windows\system32\iglhxa64.cpa
C:\Windows\system32\iglhxa64.vp
C:\Windows\system32\iglhxc64.vp
C:\Windows\system32\iglhxg64.vp
C:\Windows\system32\iglhxo64.vp
C:\Windows\system32\iglhxs64.vp
C:\Windows\SysWow64\igcompkmg500.bin
C:\Windows\SysWow64\igd10umd32.dll
C:\Windows\SysWow64\igdumd32.dll
C:\Windows\SysWow64\igfcg500m.bin
C:\Windows\SysWow64\igkmg500.bin
C:\Windows\SysWow64\iglhcp32.dll
C:\Windows\SysWow64\iglhsip32.dll
IDE ATA/ATAPI-Controller
ATA Channel 0
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys

ATA Chanel 1
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys

Intel(R) 82801GB/GR/GH(ICH7 Familie) Serieller ATA-Speichercomtroller - 27C0
C:\Windows\system32\DRIVERS\atapi.sys
C:\Windows\system32\DRIVERS\ataport.sys
C:\Windows\system32\DRIVERS\intelide.sys
C:\Windows\system32\DRIVERS\pciidx.sys
IEEE 1394-Hostcontroller
OHCI-konformer texas Instruments1394-Hostcontroller
C:\Windows\system32\DRIVERS\1394ohci.sys
Laufwerk
General UDisk USB Device
C:\Windows\system32\DRIVERS\disk.sys
C:\Windows\system32\DRIVERS\EhStorClass.sys
C:\Windows\system32\DRIVERS\partmgr.sys
SAMSUNG HD253GJ ATA Device
C:\Windows\system32\DRIVERS\disk.sys
C:\Windows\system32\drivers\EhStorClass.sys
C:\Windows\system32\drivers\partmgr.sys
Mäuse und andere Zeigegeräte
HID-konforme Mause
C:\Windows\system32\DRIVERS\mouclass.sys
C:\Windows\system32\DRIVERS\mouhid.sys
Monitore
PnP-Monitore (Standard)
C:\Windows\system32\DRIVERS\monitor.sys
Netzwerkadaptor
Realitek PCIe GBE Family Controller
C:\Windows\system32\DRIVERS\rt640x64.sys
WAN Miniport (IKEv2)
C:\Windows\system32\drivers\AgileVpn.sys
WAN Miniport (IP)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (IPv6)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (L2DP)
C:\Windows\system32\DRIVERS\rasl2tp.sys
WAN Miniport (Network Monitor)
C:\Windows\system32\DRIVERS\ndistapi.sys
C:\Windows\system32\DRIVERS\ndiswan.sys
WAN Miniport (PPPOE)
C:\Windows\system32\DRIVERS\rasppppoe.sys
WAN Miniport (PPTP)
C:\Windows\system32\drivers\raspptp.swys
WAN Miniport (SSTP)
C:\Windows\system32\DRIVERS\rassstptp.sys
Prozessoren
Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz
C:\Windows\system32\DRIVERS\intelppm.sys
Intel(R) Core(TM)2 Duo CPU E750 @ 2.93GHz
C:\Windows\system32\DRIVERS\intelppm.sys
Softwaregeräte
Brother DCP-1610W series [e89eb44818d]

ELSTON-PC: elston:

HPB6102A (HP Officejet Pro 8720)

Microsoft Device Asssociation Root Enumerator

Microsoft GS Wavetable Synthesis

Microsoft RRAS Root Enumerator

NPIA27BB4 (HP Laserjet 200 colorMFP M275nw)

Speichercontroller
Microsoft-Controller für Speicherplätze
C:\Windows\system32\DRIVERS\spacedump.sys
C:\Windows\system32\DRIVERS\spaceport.sys
Systemgeräte
1 ACIP-Schalter

2 Busenumerator für Verbundgeräte
compositebus.inf_amd64_bcb89b3386563bd7\CompositeB us.sys
3 CPU-zu-EA-Controller

4 DMA-Controller

5 Enumerator für virtuelle NDIS-Nertzwerkadaptor
C:\Windows\system32\drivers\NdisVirtualBus.sys
6 High Definition Audio Controller

C:\Windows\system32\DRIVERS\dmk.sys
C:\Windows\system32\DRIVERS\hdaudbus.sys
C:\Windows\system32\DRIVERS\portcls.sys
7 Hochpräzisionsereigniszeitgeber

8 Legacygerät

9 LPC-Controller
C:\Windows\system32\DRIVERS\msisadrv.sys
10 Microsoft ACPI-Konformers System
C:\Windows\system32\DRIVERS\acpi.sys
11 Microsoft virtueller Datenträgerenumerator
C:\Windows\system32\DRIVERS\vdrvroot.sys
12 Microsoft-Systemverwaltungs-BIOS-Treiber
C:\Windows\system32\DRIVERS\mssmbios.sys
13 Numerischer Coprozessor

14 PCI-Bus
C:\Windows\system32\DRIVERS\pci.sys
15 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
16 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
17 PCI-zu-PCI-Brücke
C:\Windows\system32\DRIVERS\pci.sys
18 PnP-Softwaregeräte-Enumerator
swenum.inf_amd64_ea7b19c04e7a8136\swenum.sys
19 Programmierbarer Interruptcontroller

20 Redirector-Bus für Remotedesktop-Geräte
C:\Windows\system32\DRIVERS\rdpbus.sys
21 SM-Bus-Controller

22 Systrem CMOS/Echtzeituhr

23 Systemlautsprecher

24 Systemzeitgeber

25 UMBus-Stamm-Busenumerator
C:\Windows\system32\DRIVERS\umbus.sys
Tastaturen
HID-Tastatur
C:\Windows\system32\DRIVERS\kbdclass.sys
C:\Windows\system32\DRIVERS\kbdhid.sys
Tragbare Geräte
USB_China2
C:\Windows\system32\DRIVERS\UMDF\WpdFs.dll
C:\Windows\system32\drivers\WpdUpFltr.sys
C:\Windows\system32\DRIVERS\WUDFRd.sys
USB-Controller
1 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CB
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
2 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C9
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
3 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CA
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
4 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27C8
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
C:\Windows\system32\drivers\usbuhci.sys
5 Intel(R) 82801G (ICH7-Familie) USB universeller Hostconroller - 27CC
C:\Windows\system32\drivers\usbehci.sys
C:\Windows\system32\drivers\usbhub.sys
C:\Windows\system32\drivers\usbport.sys
6 USB-Massenspeichergeräte
C:\Windows\system32\drivers\USBSTOR.SYS
7 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
8 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
9 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
10 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
11 USB-Root-Hub
C:\Windows\system32\drivers\usbd.sys
C:\Windows\system32\drivers\usbhub.sys
12 USB-Verbundgeräte
C:\Windows\system32\drivers\usbccgp.sys







120

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12142&viewfull=1#post12142

_____ Workbook: wbCodesBeforeFromDoubleDriver.xlsm ( Using Excel 2007 32 bit )

Double Driver Backup Non Microsoft



EG41MFT-US2H 09.02.2020 14-24-41



Display



Intel(R) G41 Express Chipset (Microsoft Corporation - WDDM 1.1)

restore.ini

oem2.inf

igdlh.cat

igdkmd64.sys

igdumd64.dll

igdumd32.dll

igkrng500.bin

igcompkrng500.bin

igfcg500m.bin

iglhxs64.vp

iglhxo64.vp

iglhxc64.vp

iglhxg64.vp

iglhxa64.vp

iglhxa64.cpa

iglhcp64.dll

iglhcp32.dll

iglhsip64.dll

iglhsip32.dll

igd10umd32.dll

igd10umd64.dll



Printer



HP LaserJet Pro 200 color MFP M275 PCL6 Class Driver

restore.ini

prnhpcl3.inf

prnhpcl3.cat



amd64

hpcP6wn8_CA.GPD

hppcl6_CA-manifest.ini

hpcPCL6_PipelineConfig.xml

hpcCFGP6.GDL

hpcP6wn8_MA.GPD

hppcl6_MA-manifest.ini

hpcP6wn8_CB.GPD

hppcl6_CB-manifest.ini

hpcP6wn8_MB.GPD

hppcl6_MB-manifest.ini

hpcP6wn8_MA_HWCP.GPD

hppcl6_MA_HWCP-manifest.ini

hpcP6wn8_CA_OJEF.GPD

hppcl6_CA_OJEF-manifest.ini

hpcP6wn8_CB_HWCP.GPD

hppcl6_CB_HWCP-manifest.ini

hpcP6wn8_CA_HWCP.GPD

hppcl6_CA_HWCP-manifest.ini

hpc6mw81.gpd

hpcstw81.dll

hpcfltw8.dll

hpcfltwb.dll

hppcl6usbext.js

hppcl6usbext.xml

hppcl6wsdext.xml



Brother Laser Type1 Class Driver

restore.ini

prnbrcl1.inf

PRNBRCL1.CAT

BRIBMF01.GPD

BRIBMF01-PIPELINECONFIG.XML

BRIBMF01-MANIFEST.INI

BRIBMF02.GPD

BRIBMF02-PIPELINECONFIG.XML

BRIBMF02-MANIFEST.INI

BRIBMF03.GPD

BRIBMF03-PIPELINECONFIG.XML

BRIBMF03-MANIFEST.INI

BRIBMF04.GPD

BRIBMF04-PIPELINECONFIG.XML

BRIBMF04-MANIFEST.INI

BRIBMF05.GPD

BRIBMF05-PIPELINECONFIG.XML

BRIBMF05-MANIFEST.INI

BRIBMF05.dpb

BRIBMF06.GPD

BRIBMF06-PIPELINECONFIG.XML

BRIBMF06-MANIFEST.INI

BRIBMF06.dpb

BRIBMF07.GPD

BRIBMF07-PIPELINECONFIG.XML

BRIBMF07-MANIFEST.INI

BRIBMF07.dpb

BRIBMF08.GPD

BRIBMF08-PIPELINECONFIG.XML

BRIBMF08-MANIFEST.INI

BRIBMF08.dpb

BRIBMF0C.GPD

BRIBMF0C-PIPELINECONFIG.XML

BRIBMF0C-MANIFEST.INI

BRIBMF0D.GPD

BRIBMF0D-PIPELINECONFIG.XML

BRIBMF0D-MANIFEST.INI

BRIBMF0E.PPD

BRIBMF0E-PIPELINECONFIG.XML

BRIBMF0E-MANIFEST.INI

BRIBREM00.GPD

BRIBMM0A.GPD

BRIBMM0A-PIPELINECONFIG.XML

BRIBMM0A-MANIFEST.INI

BRIBMM0B.GPD

BRIBMM0B-PIPELINECONFIG.XML

BRIBMM0B-MANIFEST.INI

BRIBMM0C.GPD

BRIBMM0C-PIPELINECONFIG.XML

BRIBMM0C-MANIFEST.INI

BRIBMM0D.GPD

BRIBMM0D-PIPELINECONFIG.XML

BRIBMM0D-MANIFEST.INI

BRIBME0A_200.gpd

BRIBME0A_200-MANIFEST.INI

BRIBME0A_200-PipelineConfig.xml

BRIBME0A_300.gpd

BRIBME0A_300-MANIFEST.INI

BRIBME0A_300-PipelineConfig.xml

BRIBRE01.gpd



amd64

BRIBEN01.DLL

BRIBEN02.DLL

BRIBEN03.DLL

BRIBEN04.DLL

BRIBEN05.DLL

BRIBEN06.DLL

BRIBEN07.DLL

BRIBEN08.DLL

BRIBEN0C.DLL

BRIBFRM00.DLL

BRIBFFM00.DLL

BRIBFPM00.DLL

BRIBFLM00.DLL

BRIBFTM00.DLL

BRIBFCM00.DLL

BRIBREM00.DLL

BRIBMM0A.DLL

BRIBMM0B.DLL

BRIBMM0C.DLL

BRIBFFI01.DLL

BRIBFRA01.DLL

BRIBFPR01.DLL

BRIBFPJ01.DLL

BRIBRE01.dll

BRIBME0A.dll



HP OfficeJet Pro 8720 PCL-3

restore.ini

oem3.inf

hpygid20_v4.cat

hpgid20v4-PipelineConfig.xml

hpgid20v4cfg.gdl

hpgid20v4map.xml

hpgid20v4que.xml

hpgid20v4-constraints.js

hpgid20v4-bidiEvent.xml

hpgid20v4-bidiSPM.xml

hpgid20v4-bidiWSD.xml

hpgid20v4-bidiUSB.js

hpgid20v4help.cab

hp8720.bag

hpygid20_8720-manifest.ini

hpgid20v4-bidiUSB-OPA.xml



amd64

hpbxpsv420.dll

hpygiddrv20.dll

hpUIMDDialog20.dll

hpgid20v4PE.exe

hpygidres20.dll

hpgid20v4_symbols.gpd

userfors.dll

hpgid20v4PELib.dll

hpoj_8720_v4.gpd


Worksheet: DDNonMicrosoftBefore



wbCodesBeforeFromDoubleDriver.xlsm : https://app.box.com/s/c5cxiz6rbv8frupedm26px4k51ybz7n0

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12142&viewfull=1#post12142







PrintQueue

Local Print Queue
restore.ini
printqueue.inf

USB

Intel(R) 82801G (ICH7 Family) USB Universal Host Controller - 27C8
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

Intel(R) 82801G (ICH7 Family) USB Universal Host Controller - 27C9
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

Intel(R) 82801G (ICH7 Family) USB Universal Host Controller - 27CA
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

Intel(R) 82801G (ICH7 Family) USB Universal Host Controller - 27CB
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

Intel(R) 82801G (ICH7 Family) USB2 Enhanced Host Controller - 27CC
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

USB Root Hub
restore.ini
usbport.inf
usbehci.sys
usbport.sys
usbohci.sys
usbuhci.sys
usbhub.sys
usbd.sys

USB Mass Storage Device
restore.ini
usbstor.inf
usbstor.sys

USB Composite Device
restore.ini
usb.inf
usbccgp.sys

CDROM

CD-ROM Drive
restore.ini
cdrom.inf
cdrom.sys

Computer

ACPI x64-based PC
restore.ini
hal.inf

DiskDrive

Disk drive
restore.ini
disk.inf
disk.sys

Display

Intel(R) G41 Express Chipset (Microsoft Corporation - WDDM 1.1)
restore.ini
oem2.inf
igdlh.cat
igdkmd64.sys
igdumd64.dll
igdumd32.dll
igkrng500.bin
igcompkrng500.bin
igfcg500m.bin
iglhxs64.vp
iglhxo64.vp
iglhxc64.vp
iglhxg64.vp
iglhxa64.vp
iglhxa64.cpa
iglhcp64.dll
iglhcp32.dll
iglhsip64.dll
iglhsip32.dll
igd10umd32.dll
igd10umd64.dll

HDC

Intel(R) 82801GB-GR-GH (ICH7 Family) Serial ATA Storage Controller - 27C0
restore.ini
mshdc.inf
storahci.sys
intelide.sys
storprop.dll
atapi.sys
ataport.sys
pciidex.sys
pciide.sys

IDE Channel
restore.ini
mshdc.inf
storahci.sys
intelide.sys
storprop.dll
atapi.sys
ataport.sys
pciidex.sys
pciide.sys

Keyboard

HID Keyboard Device
restore.ini
keyboard.inf
i8042prt.sys
kbdclass.sys
kbdhid.sys

MEDIA

High Definition Audio-Gerät
restore.ini
hdaudio.inf
hdaudio.sys

Microsoft Streaming Clock Proxy
restore.ini
ksfilter.inf

Microsoft Streaming Service Proxy
restore.ini
ksfilter.inf

Microsoft Streaming Quality Manager Proxy
restore.ini
ksfilter.inf

Microsoft Streaming Tee-Sink-to-Sink Converter
restore.ini
ksfilter.inf

Microsoft Trusted Audio Drivers
restore.ini
wdmaudio.inf
portcls.sys
MsApoFxProxy.dll
drmk.sys
drmkaud.sys
sysfxui.dll
wmalfxgfxdsp.dll

Monitor

Generic PnP Monitor
restore.ini
monitor.inf
monitor.sys

Generic Non-PnP Monitor
restore.ini
monitor.inf
monitor.sys

Mouse

HID-compliant mouse
restore.ini
msmouse.inf
mouclass.sys
sermouse.sys
mouhid.sys

Net

Microsoft Kernel Debug Network Adapter
restore.ini
kdnic.inf
kdnic.sys

Realtek PCIe GBE Family Controller
restore.ini
rt640x64.inf
rt640x64.sys

WAN Miniport (SSTP)
restore.ini
netsstpa.inf

WAN Miniport (IKEv2)
restore.ini
netavpna.inf

WAN Miniport (L2TP)
restore.ini
netrasa.inf

WAN Miniport (PPTP)
restore.ini
netrasa.inf

WAN Miniport (PPPOE)
restore.ini
netrasa.inf

WAN Miniport (IP)
restore.ini
netrasa.inf

WAN Miniport (IPv6)
restore.ini
netrasa.inf

WAN Miniport (Network Monitor)
restore.ini
netrasa.inf

Printer

HP LaserJet Pro 200 color MFP M275 PCL6 Class Driver
restore.ini
prnhpcl3.inf
prnhpcl3.cat

amd64
hpcP6wn8_CA.GPD
hppcl6_CA-manifest.ini
hpcPCL6_PipelineConfig.xml
hpcCFGP6.GDL
hpcP6wn8_MA.GPD
hppcl6_MA-manifest.ini
hpcP6wn8_CB.GPD
hppcl6_CB-manifest.ini
hpcP6wn8_MB.GPD
hppcl6_MB-manifest.ini
hpcP6wn8_MA_HWCP.GPD
hppcl6_MA_HWCP-manifest.ini
hpcP6wn8_CA_OJEF.GPD
hppcl6_CA_OJEF-manifest.ini
hpcP6wn8_CB_HWCP.GPD
hppcl6_CB_HWCP-manifest.ini
hpcP6wn8_CA_HWCP.GPD
hppcl6_CA_HWCP-manifest.ini
hpc6mw81.gpd
hpcstw81.dll
hpcfltw8.dll
hpcfltwb.dll
hppcl6usbext.js
hppcl6usbext.xml
hppcl6wsdext.xml

Brother Laser Type1 Class Driver
restore.ini
prnbrcl1.inf
PRNBRCL1.CAT
BRIBMF01.GPD
BRIBMF01-PIPELINECONFIG.XML
BRIBMF01-MANIFEST.INI
BRIBMF02.GPD
BRIBMF02-PIPELINECONFIG.XML
BRIBMF02-MANIFEST.INI
BRIBMF03.GPD
BRIBMF03-PIPELINECONFIG.XML
BRIBMF03-MANIFEST.INI
BRIBMF04.GPD
BRIBMF04-PIPELINECONFIG.XML
BRIBMF04-MANIFEST.INI
BRIBMF05.GPD
BRIBMF05-PIPELINECONFIG.XML
BRIBMF05-MANIFEST.INI
BRIBMF05.dpb
BRIBMF06.GPD
BRIBMF06-PIPELINECONFIG.XML
BRIBMF06-MANIFEST.INI
BRIBMF06.dpb
BRIBMF07.GPD
BRIBMF07-PIPELINECONFIG.XML
BRIBMF07-MANIFEST.INI
BRIBMF07.dpb
BRIBMF08.GPD
BRIBMF08-PIPELINECONFIG.XML
BRIBMF08-MANIFEST.INI
BRIBMF08.dpb
BRIBMF0C.GPD
BRIBMF0C-PIPELINECONFIG.XML
BRIBMF0C-MANIFEST.INI
BRIBMF0D.GPD
BRIBMF0D-PIPELINECONFIG.XML
BRIBMF0D-MANIFEST.INI
BRIBMF0E.PPD
BRIBMF0E-PIPELINECONFIG.XML
BRIBMF0E-MANIFEST.INI
BRIBREM00.GPD
BRIBMM0A.GPD
BRIBMM0A-PIPELINECONFIG.XML
BRIBMM0A-MANIFEST.INI
BRIBMM0B.GPD
BRIBMM0B-PIPELINECONFIG.XML
BRIBMM0B-MANIFEST.INI
BRIBMM0C.GPD
BRIBMM0C-PIPELINECONFIG.XML
BRIBMM0C-MANIFEST.INI
BRIBMM0D.GPD
BRIBMM0D-PIPELINECONFIG.XML
BRIBMM0D-MANIFEST.INI
BRIBME0A_200.gpd
BRIBME0A_200-MANIFEST.INI
BRIBME0A_200-PipelineConfig.xml
BRIBME0A_300.gpd
BRIBME0A_300-MANIFEST.INI
BRIBME0A_300-PipelineConfig.xml
BRIBRE01.gpd

amd64
BRIBEN01.DLL
BRIBEN02.DLL
BRIBEN03.DLL
BRIBEN04.DLL
BRIBEN05.DLL
BRIBEN06.DLL
BRIBEN07.DLL
BRIBEN08.DLL
BRIBEN0C.DLL
BRIBFRM00.DLL
BRIBFFM00.DLL
BRIBFPM00.DLL
BRIBFLM00.DLL
BRIBFTM00.DLL
BRIBFCM00.DLL
BRIBREM00.DLL
BRIBMM0A.DLL
BRIBMM0B.DLL
BRIBMM0C.DLL
BRIBFFI01.DLL
BRIBFRA01.DLL
BRIBFPR01.DLL
BRIBFPJ01.DLL
BRIBRE01.dll
BRIBME0A.dll

HP OfficeJet Pro 8720 PCL-3
restore.ini
oem3.inf
hpygid20_v4.cat
hpgid20v4-PipelineConfig.xml
hpgid20v4cfg.gdl
hpgid20v4map.xml
hpgid20v4que.xml
hpgid20v4-constraints.js
hpgid20v4-bidiEvent.xml
hpgid20v4-bidiSPM.xml
hpgid20v4-bidiWSD.xml
hpgid20v4-bidiUSB.js
hpgid20v4help.cab
hp8720.bag
hpygid20_8720-manifest.ini
hpgid20v4-bidiUSB-OPA.xml

amd64
hpbxpsv420.dll
hpygiddrv20.dll
hpUIMDDialog20.dll
hpgid20v4PE.exe
hpygidres20.dll
hpgid20v4_symbols.gpd
userfors.dll
hpgid20v4PELib.dll
hpoj_8720_v4.gpd

SCSIAdapter

Microsoft Storage Spaces Controller
restore.ini
spaceport.inf
spaceport.sys
spacedump.sys

System

Composite Bus Enumerator
restore.ini
compositebus.inf
CompositeBus.sys

UMBus Root Bus Enumerator
restore.ini
umbus.inf
umbus.sys

NDIS Virtual Network Adapter Enumerator
restore.ini
ndisvirtualbus.inf

Plug and Play Software Device Enumerator
restore.ini
swenum.inf
swenum.sys

Remote Desktop Device Redirector Bus
restore.ini
rdpbus.inf
rdpbus.sys

Microsoft ACPI-Compliant System
restore.ini
acpi.inf
acpi.sys

ACPI Power Button
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

PCI Bus
restore.ini
pci.inf
pci.sys

System board
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Legacy device
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

ACPI Fixed Feature Button
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

CPU to IO Controller
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

High Definition Audio Controller
restore.ini
hdaudbus.inf
hdaudbus.sys

PCI-to-PCI Bridge
restore.ini
pci.inf
pci.sys

LPC Controller
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

SM Bus Controller
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Motherboard resources
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Programmable interrupt controller
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Direct memory access controller
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

System timer
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

High precision event timer
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

System CMOS-real time clock
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

System speaker
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Numeric data processor
restore.ini
machine.inf
msisadrv.sys
isapnp.sys

Microsoft Virtual Drive Enumerator
restore.ini
vdrvroot.inf
vdrvroot.sys

Volume Manager
restore.ini
volmgr.inf
volmgr.sys

Microsoft Basic Display Driver
restore.ini
basicdisplay.inf
BasicDisplay.sys

Microsoft Basic Render Driver
restore.ini
basicrender.inf
BasicRender.sys

Microsoft System Management BIOS Driver
restore.ini
mssmbios.inf
mssmbios.sys

Processor

Intel Processor
restore.ini
cpu.inf
processr.sys
intelppm.sys
amdk8.sys
amdppm.sys

VolumeSnapshot

Generic volume shadow copy
restore.ini
volsnap.inf

SoftwareDevice

Generic software device
restore.ini
c_swdevice.inf

1394

Texas Instruments 1394 OHCI Compliant Host Controller
restore.ini
1394.inf
1394ohci.sys

Image

WSD-Scandienst
restore.ini
wsdscdrv.inf
WSDScDrv.dll

Volume

Volume
restore.ini
volume.inf
volume.sys

HIDClass

USB Input Device
restore.ini
input.inf
hidusb.sys
hidclass.sys
hidparse.sys

HID-compliant consumer control device
restore.ini
hidserv.inf

HID-compliant system controller
restore.ini
input.inf
hidusb.sys
hidclass.sys
hidparse.sys

HID-compliant vendor-defined device
restore.ini
input.inf
hidusb.sys
hidclass.sys
hidparse.sys

AudioEndpoint

Audio Endpoint
restore.ini
audioendpoint.inf

WSDPrintDevice

WSD Print Device
restore.ini
wsdprint.inf
wsdprint.sys

WPD

WPD-Dateisystem-Volumetreiber
restore.ini
wpdfs.inf
wpdfs.dll




wbCodesBeforeFromDoubleDriver.xlsm : https://app.box.com/s/c5cxiz6rbv8frupedm26px4k51ybz7n0

[DocAElstein]

In Support of this Post question
2020-02-15 15:08:06 https://excelribbon.tips.net/T009046_Determining_Differences_Between_Dates.html Karim K.


Determining Differences Between Dates

From Allen Wyatt, here https://excelribbon.tips.net/T009046_Determining_Differences_Between_Dates.html

….. When you are programming Excel macros, you should know that dates are stored internally, within variables, as serial numbers. The serial number represents the number of days elapsed since a starting "base date," specifically since 1 January 100. This means that you can perform math with the serial numbers, if desired. You can, for instance, find the number of days between two dates by simply subtracting the dates from each other.

If you want to get fancier in your date calculations, you can use the DateDiff function. This function allows you, for instance, to determine the number of weeks or months between two dates. In order to use the function to find this type of information, you would do as follows:


iNumWeeks = DateDiff("ww", dFirstDate, dSecondDate)
iNumMonths = DateDiff("m", dFirstDate, dSecondDate)

The first line determines the number of weeks between the two dates, and the second determines the number of months between them.
Remember that the DateDiff function is a macro (VBA) function, not a worksheet function. Excel handles a range of dates in worksheets that begin with January 1, 1900. In VBA, however, dates can begin (as already noted) in the year 100. That means that macros can handle a much larger range of dates, including dates prior to those handled natively by Excel……………..



Example: : User inputs "2/15/2019" in cell (C4) - The next day it shows "1 Day/s" and so on.


The following coding must go in the worksheets code module of the worksheet of interest:
_1 Right Click Tab _2 Select Show Code or _ 3 Double Click on worksheet in VB Editor project Explorer .JPG : https://imgur.com/1xcWkQJ , https://imgur.com/oWS0uZ4
27482749


In first worksheet Code Module

Option Explicit ' https://excelribbon.tips.net/T009046_Determining_Differences_Between_Dates.html ' https://docs.microsoft.com/de-de/office/vba/language/reference/user-interface-help/datediff-function
Public Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
Dim rngC As Range: Set rngC = Me.Range("C2:C" & (Me.UsedRange.Row + Me.UsedRange.Rows.Count - 1) & "") ' (Bottom left of Usedrange + Row count in UsedRange) - 1 will give us the last row
Dim rngStr As Range
For Each rngStr In rngC
Debug.Print rngStr.Value ' From VB Editor, Hit keys Ctrl + g to see the immediate window
If rngStr <> "" Then
Dim Vl As String: Let Vl = rngStr.Value
If Len(Vl) < 8 Then MsgBox Prompt:=Vl & " is too short for a date": GoTo Nxt
If Len(Vl) - Len(Replace(Vl, "/", "")) <> 2 Then MsgBox Prompt:="Don't have 2 ""/""s in " & Vl: GoTo Nxt
Dim Dey As String, Munf As String, Jear As String
Dim strSplt() As String: Let strSplt() = Split(Vl, "/", 3, vbBinaryCompare) ' https://imgur.com/1xcWkQJ
Let Dey = strSplt(1): Munf = strSplt(0): Jear = strSplt(2)
Dim Dte As Date, strDte As String, LngDte As Long
Let strDte = Format(Dey & " " & Munf & " " & Jear, "dd mmmm yyyy"): Debug.Print strDte
Let Dte = CDate(strDte)
Let strDte = Format(Dey & " " & Munf & " " & Jear, "dd" & ", " & "mmmm" & ", " & "yyyy"): Debug.Print strDte
Let LngDte = CLng(Dte) ' Allen Wyatt: When you are programming Excel macros, you should know that dates are stored internally, within variables, as serial numbers. The serial number represents the number of days elapsed since a starting "base date," specifically since 1 January 100. This means that you can perform math with the serial numbers, if desired. You can, for instance, find the number of days between two dates by simply subtracting the dates from each other.
Dim LngNow As Long: Let LngNow = CLng(Now())
' https://excelribbon.tips.net/T009046_Determining_Differences_Between_Dates.html ' https://docs.microsoft.com/de-de/office/vba/language/reference/user-interface-help/datediff-function
Dim iNumDays As Long, iNumWeeks As Long, iNumMonths As Long
Let iNumDays = DateDiff("d", LngDte, LngNow) ' = LngNow-LngDte
Let iNumWeeks = DateDiff("w", LngDte, LngNow)
Let iNumMonths = DateDiff("m", LngDte, LngNow)
Let Application.EnableEvents = False
Let rngStr.Offset(0, 1).Value = iNumDays & " Days, " & iNumWeeks & " Weeks, and " & iNumMonths & " Months."
Let rngStr.Offset(0, 2).Value = strDte
Let Application.EnableEvents = True
Else ' case empty cell
End If
Nxt: Next rngStr
Else ' No change in column 3 ( "C" )
End If

Me.Columns.AutoFit
End Sub

Note:
You may need to adjust the coding a bit with a +1 or -1 somewhere to get the day count output exactly as you want it


The above macro will start automatically when you add a date into column “C” , provided it has this sort of format
2/15/2020
( Month/Day/Year )


The following additional macro, will ensure that the worksheet is updated when the workbook is opened

Macro in ThisWorkbook code module

Private Sub Workbook_Open()
Call Tabelle1.Worksheet_Change(Worksheets.Item(1).Range ("C2"))
End Sub

The above code module and coding therein can be seen by double clicking on the ThisWorkbook code module in the VB Editor explorer:
Double Click on ThisWorkbook in VB Editor Explorer.jpg : https://imgur.com/Kls33SD
2747

Note, In order to call our macro Public Sub Worksheet_Change(ByVal Target As Range) in this way, we have changed the more typically seen , default option of Private to Public in the first macro in the worksheets code module

Here is a typical output
_____ Workbook: KarimKAllenWyattDateDifferences.xlsm ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
F

3


42/15/20202 Days, 0 Weeks, and 0 Months.15, Februar, 2020


51/15/202033 Days, 4 Weeks, and 1 Months.15, Januar, 2020


66


73/12/2019342 Days, 48 Weeks, and 11 Months.12, März, 2019


82/16/20201 Days, 0 Weeks, and 0 Months.16, Februar, 2020


9z
Worksheet: Tabelle1



KarimKAllenWyattDateDifferences.xlsm : https://app.box.com/s/ti0n1wj62hcd2qmhcg5kiqle1sya79ux

[DocAElstein]

In support of this postpost
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page8
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page8#post12252
( see also here : http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12147&viewfull=1#post12147
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12148&viewfull=1#post12148 )



First a "VBA" arrays type macro to count the total number of files with their extensions , then a "spreadsheet" type equivalent extended also to look at the color of the cells

Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Select Case Xtn
Case "sys", "SYS"
Let Sys = Sys + 1
Case "dll"
Let Ddl = Ddl + 1
Case "bin"
Let Bin = Bin + 1
Case "cpa"
Let Cpa = Cpa + 1
Case "vp"
Let Vp = Vp + 1
Case Else
Debug.Print "Case Else " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path
End If
End If
Next ClCnt
Next RwCnt
Rem 4 output

Debug.Print "sys " & Sys
Debug.Print "ddl " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "els " & Els

End Sub


Sub WotsANormalCellColor()
Let Range("A1").Value = "AnyText"
Debug.Print Range("A1").Font.Color & " " & Range("A1").Font.ColorIndex ' we seee that Color for black or automatic is 0 ColorIndex for black is 1 for automatic is -4105
End Sub




' The next code and the one in the next post is the spreadsheet type equivalent extended also to look at the color of the cells
Sub FileTypesHere()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim RngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each RngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If RngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(RngStr.Value, (InStr(4, RngStr.Value, ".", vbBinaryCompare) + 1))
Select Case Xtn
Case "sys", "SYS"
Let Sys = Sys + 1: If RngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "dll"
Let Ddl = Ddl + 1: If RngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "bin"
Let Bin = Bin + 1:: If RngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "cpa"
Let Cpa = Cpa + 1: If RngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "vp"
Let Vp = Vp + 1: If RngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
Case Else
Debug.Print "Case Else " & RngStr.Value
Let Els = Els + 1: If RngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next RngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els & " (" & Els2 & ")"

End Sub

[DocAElstein]

Some coding in support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page8#post12252
for worksheet "DDAllBefore"


( see also here : http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12147&viewfull=1#post12147
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel?p=12148&viewfull=1#post12148 )


Option Explicit
Sub ColumnsE()
Columns("E:E").SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers).Copy
Paste Destination:=Range("E680")
End Sub


Sub FileTypesHere()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("F5:G670")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Inf2 As Long, Ini2 As Long, Cat2 As Long, Gpd2 As Long, Xml2 As Long, Gdl2 As Long
Dim Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Dim Js2 As Long, Dpd2 As Long, Ppd2 As Long, Cab2 As Long, Bag2 As Long, Exe2 As Long
Dim Dpb As Long
Dim Dpb2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim RngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each RngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If RngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(RngStr.Value, (InStr(2, RngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If RngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If RngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If RngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If RngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If RngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Case "INF"
Let Inf = Inf + 1: If RngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "INI"
Let Ini = Ini + 1: If RngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If RngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If RngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "XML"
Let Xml = Xml + 1: If RngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If RngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Case "JS"
Let Js = Js + 1: If RngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "DPD"
Let Dpd = Dpd + 1: If RngStr.Font.Color <> 0 Then Let Dpd2 = Dpd2 + 1
Case "PPD"
Let Ppd = Ppd + 1: If RngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
Case "CAB"
Let Cab = Cab + 1: If RngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "BAG"
Let Bag = Bag + 1: If RngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "EXE"
Let Exe = Exe + 1: If RngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' DPB
Case "DPB"
Let Dpb = Dpb + 1: If RngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1


Case Else
Debug.Print "Case Else " & RngStr.Value
Let Els = Els + 1:: If RngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next RngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els & " (" & Els2 & ")"
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "dpd " & Dpd & " (" & Dpd2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "ppd " & Ppd & " (" & Ppd & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' DPB
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")"
End Sub

[DocAElstein]

Some additional coding to help in this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page9post12255

(VBA "arrays" version)

Option Explicit
Private Sub FileTypesHereArrays()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E75")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
Case "DLL"
Let Ddl = Ddl + 1
Case "BIN"
Let Bin = Bin + 1
Case "CPA"
Let Cpa = Cpa + 1
Case "VP"
Let Vp = Vp + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1
Case "XML"
Let Xml = Xml + 1
Case "JS"
Let Js = Js + 1
Case "GDL"
Let Gdl = Gdl + 1
Case "CAB"
Let Cab = Cab + 1
Case "INI"
Let Ini = Ini + 1
Case "CAT"
Let Cat = Cat + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1
Case "PNF"
Let Pnf = Pnf + 1
Case "GPD"
Let Gpd = Gpd + 1
Case "EXE"
Let Exe = Exe + 1
Case Else
Debug.Print "Case Else " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path
End If
End If
Next ClCnt
Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys
Debug.Print "dll " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag
Debug.Print "xml " & Xml
Debug.Print "js " & Js
Debug.Print "gdl " & Gdl
Debug.Print "cab " & Cab
Debug.Print "ini " & Ini
Debug.Print "cat " & Cat
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf
Debug.Print "pnf " & Pnf
Debug.Print "gpd " & Gpd
Debug.Print "exe " & Exe
Debug.Print "Total is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page9post12255



'
Sub CompareDriverFilesCommandInDeviceManager() ' InDoubleDriverAllList()
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsCmd As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsCmd = Worksheets("PowerShell")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DeviceManagerProperties!D2:DeviceManagerPropertie s!F265") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DeviceManagerProperties!D2"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
'Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDMP.Activate: FndCel.Select
'Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

Some additional coding to help in this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page9post12255

("spreadsheet interaction" version)




Private Sub FileTypesHereSpreadsheetInteraction()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
Debug.Print "Total is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe
End Sub

[DocAElstein]

In support of this Post

http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page9#post12263


Macro to colour match file entries in the two worksheets,
PowerShell
and
DDAllBefore



Option Explicit
Sub CompareDriverFilesCommandInDoubleDriver() ' DeviceManager() ' InDoubleDriverAllList()
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDD As Worksheet, WsCmd As Worksheet
Set WsDD = Worksheets("DDAllBefore"): Set WsCmd = Worksheets("PowerShell")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DDAllBefore!D5:DDAllBefore!G670") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
'Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDD.Activate: FndCel.Select
'Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

' In support of this excelfox post : http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page10#post12271
' File to list all file types , and (those also appearing in DoubleDriver worksheet, ( Worksheets "DDAllBefore" ) )





' In support of this excelfox post : http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page10#post12271
' File to list all file types , and (those also appearing in DoubleDriver worksheet, ( Worksheets "DDAllBefore" ) )
Private Sub FileTypesHereAndAlsoInDoubleDriver()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Worksheets("PowerShell") ' Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
Debug.Print "Total is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page11#post12276


Option Explicit
Private Sub FileTypesHereArrays()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E180")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Sam As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot .
' this next section catches single . things
If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single .
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
Case "DLL"
Let Ddl = Ddl + 1
Case "BIN"
Let Bin = Bin + 1
Case "CPA"
Let Cpa = Cpa + 1
Case "VP"
Let Vp = Vp + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1
Case "XML"
Let Xml = Xml + 1
Case "JS"
Let Js = Js + 1
Case "GDL"
Let Gdl = Gdl + 1
Case "CAB"
Let Cab = Cab + 1
Case "INI"
Let Ini = Ini + 1
Case "CAT"
Let Cat = Cat + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1
Case "PNF"
Let Pnf = Pnf + 1
Case "GPD"
Let Gpd = Gpd + 1
Case "EXE"
Let Exe = Exe + 1
' sam
Case "SAM"
Let Sam = Sam + 1
Case Else
Debug.Print "Case Else for single "" . "" " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui
' this next section catches double . . things
Dim DllMui As Long, SysMui As Long, Els2 As Long
Select Case UCase(Xtn)
Case "DLL.MUI"
Let DllMui = DllMui + 1
Case "SYS.MUI"
Let SysMui = SysMui + 1
Case Else
Debug.Print "Case Else for double "" . . "" " & arrFiles(RwCnt, ClCnt)
Let Els2 = Els2 + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) > 2 Then
' this section catches strings with dots more than 2
Dim LtsDts As Long
Debug.Print "More than 2 dots -- " & arrFiles(RwCnt, ClCnt)
Let LtsDts = LtsDts + 1
End If
Else ' not a file, ( well no . in it anyway )
Dim Fldr As Long
Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt)
Let Fldr = Fldr + 1
End If
End If
Next ClCnt
Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys
Debug.Print "dll " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "Else1 " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag
Debug.Print "xml " & Xml
Debug.Print "js " & Js
Debug.Print "gdl " & Gdl
Debug.Print "cab " & Cab
Debug.Print "ini " & Ini
Debug.Print "cat " & Cat
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf
Debug.Print "pnf " & Pnf
Debug.Print "gpd " & Gpd
Debug.Print "exe " & Exe
' sam
Debug.Print "sam " & Sam
' Dim DllMui As Long, SysMui As Long, Els2 As Long
Debug.Print "dll.mui " & DllMui
Debug.Print "sys.mui " & SysMui
Debug.Print "Else2 " & Els2
Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam
Debug.Print "Total Folders is " & Fldr
Debug.Print "Total things with more than 2 dots is " & LtsDts
End Sub

[DocAElstein]

In support of this post:
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page14#post12319



Sub FileTypesHereInDeviceManagerProperties()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(rngStr.Value, 3) = "C:\" And InStr(4, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(4, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1: If rngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els & " (" & Els2 & ")"

End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page14#post12323







'====================================
' Dec 2017 For Python Comparison. Tutorial Post: excelforum: https://www.excelforum.com/tips-and-tutorials/1213798-all-sub-folder-and-file-list-from-vba-recursion-routine-explanation-and-method-comparison.html Tutorial Post: ExcelFox: http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10420#post10420
'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 = ActiveSheet ' 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 & "\" & "DriverStore" ' "Double Driver Backup All" ' "Double Driver Backup Non Microsoft" ' "PowerShell driverbackup" ' "driverbackup" ' "Before" ' '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) --
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

[DocAElstein]

in support of this Thread post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page14#post12323





Option Explicit
Private Sub FileTypesHereArrays()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("A1:F4437")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Sam As Long
Dim Inf_loc As Long, Hlp As Long, Ntf As Long, Ppd As Long, Tbl As Long, Icc As Long, Dat As Long
Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If ClCnt = 2 And arrFiles(RwCnt, ClCnt) <> "" Then ' case of folder path
Dim Fldr As Long ' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt)
Let Fldr = Fldr + 1
Let RwCnt = RwCnt + 1 ' this is naughty, but will stop us hitting the folder name as the columns increase
Else ' not a folder and if empty then not in column 2
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot .
' this next section catches single . things
If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single .
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
Case "DLL"
Let Ddl = Ddl + 1
Case "BIN"
Let Bin = Bin + 1
Case "CPA"
Let Cpa = Cpa + 1
Case "VP"
Let Vp = Vp + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1
Case "XML"
Let Xml = Xml + 1
Case "JS"
Let Js = Js + 1
Case "GDL"
Let Gdl = Gdl + 1
Case "CAB"
Let Cab = Cab + 1
Case "INI"
Let Ini = Ini + 1
Case "CAT"
Let Cat = Cat + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1
Case "PNF"
Let Pnf = Pnf + 1
Case "GPD"
Let Gpd = Gpd + 1
Case "EXE"
Let Exe = Exe + 1
' sam
Case "SAM"
Let Sam = Sam + 1
'inf_loc Pnf HLP NTF Ppd TBL ICC DAT
Case "INF_LOC"
Let Inf_loc = Inf_loc + 1
Case "HLP"
Let Hlp = Hlp + 1
Case "NTF"
Let Ntf = Ntf + 1
Case "PPD"
Let Ppd = Ppd + 1
Case "TBL"
Let Tbl = Tbl + 1
Case "ICC"
Let Icc = Icc + 1
Case "DAT"
Let Dat = Dat + 1
'Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Case "DPB"
Let Dpb = Dpb + 1
Case "CTY"
Let Cty = Cty + 1
Case "MSC"
Let Msc = Msc + 1
Case "XST"
Let Xst = Xst + 1
Case Else
Debug.Print "Case Else for single "" . "" " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui
' this next section catches double . . things
Dim DllMui As Long, SysMui As Long, Els2 As Long
Select Case UCase(Xtn)
Case "DLL.MUI"
Let DllMui = DllMui + 1
Case "SYS.MUI"
Let SysMui = SysMui + 1
Case Else
Debug.Print "Case Else for double "" . . "" " & arrFiles(RwCnt, ClCnt)
Let Els2 = Els2 + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) > 2 Then
' this section catches strings with dots more than 2
Dim LtsDts As Long
Debug.Print "More than 2 dots -- " & arrFiles(RwCnt, ClCnt)
Let LtsDts = LtsDts + 1
End If
Else ' not a file, ( well no . in it anyway )
' Dim Fldr As Long
' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt)
' Let Fldr = Fldr + 1
End If
End If ' end of case empty cell
End If ' end of folder is counted based on "G:\" in column B
Next ClCnt
Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys
Debug.Print "dll " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "Else1 " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag
Debug.Print "xml " & Xml
Debug.Print "js " & Js
Debug.Print "gdl " & Gdl
Debug.Print "cab " & Cab
Debug.Print "ini " & Ini
Debug.Print "cat " & Cat
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf
Debug.Print "pnf " & Pnf
Debug.Print "gpd " & Gpd
Debug.Print "exe " & Exe
' sam
Debug.Print "sam " & Sam
' inf_loc Pnf HLP NTF Ppd TBL ICC DAT
Debug.Print "inf_loc " & Inf_loc
Debug.Print "pnf " & Pnf
Debug.Print "hlp " & Hlp
Debug.Print "ntf " & Ntf
Debug.Print "ppd " & Ppd
Debug.Print "tbl " & Tbl
Debug.Print "icc " & Tbl
Debug.Print "dat " & Dat
' Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Debug.Print "dpb " & Dpb
Debug.Print "cty " & Cty
Debug.Print "msc " & Msc
Debug.Print "xst " & Xst
' Dim DllMui As Long, SysMui As Long, Els2 As Long
Debug.Print "dll.mui " & DllMui
Debug.Print "sys.mui " & SysMui
Debug.Print "Else2 " & Els2
Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam + Inf_loc + Hlp + Ntf + Ppd + Tbl + Icc + Dat + Dpb + Cty + Msc + Xst
Debug.Print "Total Folders is " & Fldr
Debug.Print "Total things with more than 2 dots is " & LtsDts
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page14#post12324
This is matching Device Manager Properties to DriverStore

This is the first use of italicising, in plce of coloring to indicate the match, becaus we want to retain the colour as an indication that a match was found in drivers


Sub CompareDriverFilesDeviceManagerInDriverStore() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page11#post12277
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDrSt As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDrSt = Worksheets("DriverStore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDMP.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True

WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6 (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg)
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg (https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page18#post12360




Sub FileTypesHereInDeviceManagerPropertiesUndDriverSto reUnddrivers() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page18#post12360
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(rngStr.Value, 3) = "C:\" And InStr(4, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(4, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Italic = True Then Let Sys2 = Sys2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Italic = True Then Let Ddl2 = Ddl2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Italic = True Then Let Bin2 = Bin2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Italic = True Then Let Cpa2 = Cpa2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Italic = True Then Let Vp2 = Vp2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1: If rngStr.Font.Italic = True Then Let Els2 = Els2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Els3 = Els3 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ") [" & Els3 & "]"

Debug.Print "Totals " & Sys + Ddl + Bin + Cpa + Vp + Els & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 & "]"
End Sub

[DocAElstein]

In support of this Thread: http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=12530#post12530



..save and close the sample2.xls and sample3.xlsb...

To help get syntax we can use a macro recording…


Macro recording for simple save..

Open sample2.xls
Open sample3.xlsb
Open sample1.xlsm

StartMacroRecording.JPG : https://imgur.com/4KAUJGa
NameRecordingMacro.JPG : https://imgur.com/AP6qdY2

Save sample2 xls.jpg : https://imgur.com/JhQEZzv
Close sample2 xls.JPG : https://imgur.com/aEKtCTN

Save sample3 xlsb.JPG : https://imgur.com/ontjd4z
Close sample3 xlsb.JPG : https://imgur.com/kbDEhfm

Stop Recording Macro.JPG : https://imgur.com/loqaTkc

Recorded Macro.JPG : https://imgur.com/SFY0jcW




Sub AvASave()
'
' AvASave Makro
'

'
Windows("sample2.xls").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("sample3.xlsb").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub



Macro recording for Save As..

Open sample2.xls
Open sample3.xlsb
Open sample1.xlsm

StartMacroRecording.JPG : https://imgur.com/4KAUJGa
NameRecordingMacro2.JPG : https://imgur.com/mDEneOt

SaveAs sample2 xls.jpg : https://imgur.com/xjqgPRO , https://imgur.com/UpT3pAB
Close sample2 xls.JPG : https://imgur.com/aEKtCTN

SaveAs sample3 xlsb.JPG : https://imgur.com/QF5yo6L , https://imgur.com/hgyV1Tm
Close sample3 xlsb.JPG : https://imgur.com/kbDEhfm

Stop Recording Macro.JPG : https://imgur.com/loqaTkc

Recorded Macro2.JPG : https://imgur.com/zHm6DY2


Sub AvASaveAs()
'
' AvASaveAs Makro
'
Windows("sample2.xls").Activate
ActiveWorkbook.SaveAs Filename:= _
"F:\Excel0202015Jan2016\ExcelFox\vixer\sample2.xls", FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close
Windows("sample3.xlsb").Activate
ActiveWorkbook.SaveAs Filename:= _
"F:\Excel0202015Jan2016\ExcelFox\vixer\sample3.xlsb", FileFormat:=xlExcel12, _
CreateBackup:=False
ActiveWorkbook.Close
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page19#post12364



Sub FileTypesHereDoubleDriverFull()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("F5:G670")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Inf2 As Long, Ini2 As Long, Cat2 As Long, Gpd2 As Long, Xml2 As Long, Gdl2 As Long
Dim Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Dim Js2 As Long, Dpd2 As Long, Ppd2 As Long, Cab2 As Long, Bag2 As Long, Exe2 As Long
Dim Dpb As Long
Dim Dpb2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "DPD"
Let Dpd = Dpd + 1: If rngStr.Font.Color <> 0 Then Let Dpd2 = Dpd2 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' DPB
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1


Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1:: If rngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els & " (" & Els2 & ")"
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "dpd " & Dpd & " (" & Dpd2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' DPB
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")"

Debug.Print " Total " & Sys + Ddl + Bin + Cpa + Vp + Els + Inf + Ini + Cat + Gpd + Xml + Gdl + Js + Dpd + Cab + Bag + Ppd + Exe + Dpb & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 + Inf2 + Ini2 + Cat2 + Gpd2 + Xml2 + Gdl2 + Js2 + Dpd2 + Cab2 + Bag2 + Ppd2 + Exe2 + Dpb2 & ")"
End Sub

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page19#post12364


Sub Compare_drivers_In_DoubleDriver() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page19#post12364
Rem 0
If ActiveSheet.Name <> "drivers" Then ' This macro was intended to be run from drivers to look for things from it in DoubleDriver
MsgBox prompt:="Oops": Exit Sub ' **the selection should be in drivers
Else
End If
Rem 1 Worksheets info
Dim WsDD As Worksheet, WsDrs As Worksheet
Set WsDD = Worksheets("DDAllBefore"): Set WsDrs = Worksheets("drivers")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range, **the selection should be in drivers
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Replace(CelVl, ".mui", "", 1, 1, vbBinaryCompare) ' Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DDAllBefore!D5:DDAllBefore!G670") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDrs.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx

WsDD.Activate: FndCel.Select ' the other workseet, that being looked in for the file
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub







ExplorerBefore Double Driver V DriverStore Abort.xlsm : https://app.box.com/s/uqupktt1ppxar3frhg2n7tqbb9vn181e

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page21#post12386


Sub CompareDriverFilesDoubleDriverInDriverStoreFindNex t() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page21#post12386
Rem 0
If ActiveSheet.Name <> "DDAllBefore" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDD As Worksheet, WsDrSt As Worksheet
Set WsDD = Worksheets("DDAllBefore"): Set WsDrSt = Worksheets("DriverStore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file
Dim FileNmeSrchFor As String
'Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Let FileNmeSrchFor = CelVl ' In Double Drivers the cells are not shown as a full path, so the last line is not necerssary
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Do While Not FndCel Is Nothing ' Start Find next loop =
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDD.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDD.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True

WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Set FndCel = Application.Range("=DriverStore!D" & FndCel.Row + 1 & ":DriverStore!F4437").Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!F4437"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '
Loop ' End Find next loop ========================
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

Do While Loop start further down macro in support of this Post:




Sub CompareDriverFilesDoubleDriverInDriverStoreFindNex t() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page21#post12386
Rem 0
If ActiveSheet.Name <> "DDAllBefore" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDD As Worksheet, WsDrSt As Worksheet
Set WsDD = Worksheets("DDAllBefore"): Set WsDrSt = Worksheets("DriverStore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file
Dim FileNmeSrchFor As String
'Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Let FileNmeSrchFor = CelVl ' In Double Drivers the cells are not shown as a full path, so the last line is not necerssary
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
'Do While Not FndCel Is Nothing ' Start Find next loop =
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDD.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
Do While Not FndCel Is Nothing ' Start Find next loop ======
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDD.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True

WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Set FndCel = Application.Range("=DriverStore!D" & FndCel.Row + 1 & ":DriverStore!F4437").Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!F4437"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '
Loop ' End Find next loop =================================
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

In support of answer for this Thread:
http://www.excelfox.com/forum/showthread.php/2425-Copy-and-paste-by-highlighted-colour


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

1
Stock Name








2
A2
22
32
42
52
62
72


3
A3
23
33
43
53
63
73


4
A4
24
34
44
54
64
74


5
A5
25
35
45
55
65
75


6
A6
26
36
46
56
66
76


7
A7
27
37
47
57
67
77


8
A8
28
38
48
58
68
78
Worksheet: Tabelle1


After the following code section we have a modified worksheet

Rem 2 .... initial adjustment so that I can detect the highlighted cells in a different way
Dim Rng As Range
For Each Rng In Ws1.UsedRange.Offset(0, 2).Resize(, Ws1.UsedRange.Columns.Count - 1)
If Rng.Interior.Color = 65535 Then
Let Rng.Value = "=" & """" & Rng.Value & """"
Else
End If

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

1
Stock Name









2
A2
22
32
42
52
62
72



3
A3
23
="33"
43
53
63
73



4
A4
24
34
44
="54"
64
="74"



5
A5
25
35
="45"
55
65
75



6
A6
26
36
46
56
66
76



7
A7
27
37
47
57
="67"
77



8
A8
28
38
48
58
68
78



9








Worksheet: Tabelle1

First worksheet in 2.xlsx, before running macro, showing the Matched A5 in row 6
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1Symbol


2xH2


3rH3


4fH4


5gdgH5


6A5H6


7
5H7


8hH8


9
Worksheet: Tabelle1


After running macro:-
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1Symbol


2xH2


3rH3


4fH4


5gdgH5


6A5H645


7
5H7


8hH8


9
Worksheet: Tabelle1



1.xlsx : https://app.box.com/s/dgufdfvw3lm3knkvwvp0xgiqpwarqf69
2.xlsx : https://app.box.com/s/51cykk4zd6ldan8puz70o3zyj0e17rwf
macro.xlsm : https://app.box.com/s/tbis0g4n6l6386df6xjwh4cirbtgphzl

[DocAElstein]

In support of this Forum post:
http://www.excelfox.com/forum/showthread.php/2425-Copy-and-paste-by-highlighted-colour-Paste-Highlighted-Cells-From-Matched-Column-Rows?p=12575&viewfull=1#post12575


Before:
_____ Workbook: 1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1Stock NameDataDataDataDataDataDataDataDataDataDataDataDa ta


2ACC
800
700
600
500
400
300
200
100
90
80
70


3ADANIENT
800
700
600
500
400
300
200
100
90
80
70


4ADANIPORTS
800
700
600
500
400
300
200
100
90
80
70If there are no highlighted colour cells in the row then copy paste the firt cells of that row i. e 800(B4)


5ADANIPOWER
800
700
600
500
400
300
200
100
90
80
70and sorry Doc Sir one mistake happened from my end in providing the info to u , we have to copy and paste the data after highlighted colours cells


6AMARAJABAT
800
700
600
500
400
300
200
100
90
80
70And one more thing plz see A8 it doesnt have highlighted colour cells in that row then we have to copy and paste the first cell i. e B8(800)but A8 will not match with column B of 2.xlsx so ignore that don't do anything for that just ignore it


7AMBUJACEM
800
700
600
500
400
300
200
100
90
80
70


8ONGC
800
700
600
500
400
300
200
100
90
80
70


9
Worksheet: Sheet1
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
130
132.7
127.4
139.1
130.3


3NSEAMARAJABATEQ
102.35
104.7
101
105.65
103.55


4NSEADANIENTEQ
215.1
216.65
207.5
221.75
210.35


5NSEAMBUJACEMEQ
198.75
202.4
195.4
204.4
201.05


6NSEADANIPORTSEQ
339.8
339.8
331.25
349.15
336.35


7NSEADANIPOWEREQ
268
273.65
253.95
288.5
270.1


8
Worksheet: Sheet1
need match column A stock name of 1.xlsx with column B of 2. xlsx and if it matches then we have to copy and paste the data after highlighted colours cells in that row of 1.xlsx and paste it to column L OF 2.xlsx

If there are no highlighted colour cells in the row then copy paste the firt cells of that row i. e 800(B4)
And one more thing plz see A8 it doesnt have highlighted colour cells in that row then we have to copy and paste the first cell i. e B8(800)but A8 will not match with column B of 2.xlsx so ignore that don't do anything for that just ignore it


here is after
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
130
132.7
127.4
139.1
130.3
400


3NSEAMARAJABATEQ
102.35
104.7
101
105.65
103.55
300


4NSEADANIENTEQ
215.1
216.65
207.5
221.75
210.35
600


5NSEAMBUJACEMEQ
198.75
202.4
195.4
204.4
201.05
800


6NSEADANIPORTSEQ
339.8
339.8
331.25
349.15
336.35
800


7NSEADANIPOWEREQ
268
273.65
253.95
288.5
270.1
200


8
Worksheet: Sheet1

_.______________________

here is latest macro, in next post....

[DocAElstein]

Macro for last post

Sub PasteHighlightedCellsFromMatchedColumnRows2() ' http://www.excelfox.com/forum/showthread.php/2425-Copy-and-paste-by-highlighted-colour-Paste-Highlighted-Cells-From-Matched-Column-Rows?p=12575&viewfull=1#post12575
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Workbooks("1.xlsx").Worksheets.Item("Sheet1"): Set Ws2 = Workbooks("2.xlsx").Worksheets.Item("Sheet1")
Rem 2 .... initial adjustment so that I can detect the highlighted cells in a different way
Dim Rng As Range
' For Each Rng In Ws1.UsedRange.Offset(0, 2).Resize(, Ws1.UsedRange.Columns.Count - 2) ' We are intersted in the range offset 2 columns to the left of size 2 columns less than the main used range
For Each Rng In Ws1.Range("A2:L" & Ws1.UsedRange.Rows.Count & "")
If Rng.Interior.Color = 65535 Then
Let Rng.Value = "=" & """" & Rng.Value & """"
Else
End If
Next Rng
Rem 3 match column A stock name of 1.xlsx with column B of 2.xlsx and if it matches then copy the yellow highlighted colured cell data in that row of 1.xlsx and paste it to column L OF 2.xlsx
Dim Lr1 As Long: Let Lr1 = Ws1.UsedRange.Rows.Count
For Each Rng In Ws1.Range("A2:A" & Lr1 & "") ' Ws1 column A
Dim Lr2 As Long: Let Lr2 = Ws2.UsedRange.Rows.Count
Dim SrchRng As Range: Set SrchRng = Ws2.Range("B2:B" & Lr2 & "")
Dim RngMtch As Range
Set RngMtch = SrchRng.Find(What:=Rng.Value, After:=Ws2.Range("B2"), LookAt:=xlWhole, searchorder:=xlNext, MatchCase:=True) '
If RngMtch Is Nothing Then

Else ' a cell from column a 1.xlsx is matched to a cell from column B 2.xlsx
Dim HigChk As Range
Set HigChk = Rng.Offset(0, 1).Resize(, Ws1.UsedRange.Columns.Count - 1).Find(What:="=", LookIn:=xlFormulas, LookAt:=xlPart)
If Not HigChk Is Nothing Then ' we found a highlighted cell -----------
' copy the yellow highlighted colured cell data in that row of 1.xlsx
Rng.Offset(0, 1).Resize(, Ws1.UsedRange.Columns.Count - 1).SpecialCells(xlCellTypeFormulas, xlNumbers + xlTextValues).Offset(0, 1).Copy
' paste it to column L OF 2.xlsx
Else ' case no highlighted cell, so column B should be copüied from 1.xlsx
Rng.Offset(0, 1).Copy
End If ' we were looking for highligted cell ---
Ws2.Range("L" & RngMtch.Row & "").PasteSpecial Paste:=xlPasteValues
End If
Next Rng ' Ws1 column A
Rem 4 save and close both the file after doing the process
Workbooks("1.xlsx").Close savechanges:=False
Workbooks("2.xlsx").Close savechanges:=True
End Sub




1.xlsx : https://app.box.com/s/dgufdfvw3lm3knkvwvp0xgiqpwarqf69
2.xlsx : https://app.box.com/s/51cykk4zd6ldan8puz70o3zyj0e17rwf
macro.xlsm : https://app.box.com/s/tbis0g4n6l6386df6xjwh4cirbtgphzl

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page29#post12481





Sub FileTypesHereDoubleDriverFull_Clamers_SquareBracke ts()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("F5:G670")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Inf2 As Long, Ini2 As Long, Cat2 As Long, Gpd2 As Long, Xml2 As Long, Gdl2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Dim Inf3 As Long, Ini3 As Long, Cat3 As Long, Gpd3 As Long, Xml3 As Long, Gdl3 As Long
Dim Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Dim Js2 As Long, Dpd2 As Long, Ppd2 As Long, Cab2 As Long, Bag2 As Long, Exe2 As Long
Dim Js3 As Long, Dpd3 As Long, Ppd3 As Long, Cab3 As Long, Bag3 As Long, Exe3 As Long
Dim Dpb As Long
Dim Dpb2 As Long
Dim Dpb3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Inf3 = Inf3 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ini3 = Ini3 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cat3 = Cat3 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Gpd3 = Gpd3 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Xml3 = Xml3 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Gdl3 = Gdl3 + 1
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Js3 = Js3 + 1
Case "DPD"
Let Dpd = Dpd + 1: If rngStr.Font.Color <> 0 Then Let Dpd2 = Dpd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Dpd3 = Dpd3 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ppd3 = Ppd3 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cab3 = Cab3 + 1
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bag3 = Bag3 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Exe3 = Exe3 + 1
' DPB
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Dpd3 = Dpd3 + 1


Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1:: If rngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ")"
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Debug.Print "inf " & Inf & " (" & Inf2 & ") [" & Inf3 & "]"
Debug.Print "ini " & Ini & " (" & Ini2 & ") [" & Ini3 & "]"
Debug.Print "cat " & Cat & " (" & Cat2 & ") [" & Cat3 & "]"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ") [" & Gpd3 & "]"
Debug.Print "xml " & Xml & " (" & Xml2 & ") [" & Xml3 & "]"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ") [" & Gdl3 & "]"
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Debug.Print "js " & Js & " (" & Js2 & ") [" & Js3 & "]"
Debug.Print "dpd " & Dpd & " (" & Dpd2 & ") [" & Dpd3 & "]"
Debug.Print "cab " & Cab & " (" & Cab2 & ") [" & Cab3 & "]"
Debug.Print "bag " & Bag & " (" & Bag2 & ") [" & Bag3 & "]"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ") [" & Ppd3 & "]"
Debug.Print "exe " & Exe & " (" & Exe2 & ") [" & Exe3 & "]"
' DPB
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ") [" & Dpb3 & "]"

Debug.Print " Total " & Sys + Ddl + Bin + Cpa + Vp + Els + Inf + Ini + Cat + Gpd + Xml + Gdl + Js + Dpd + Cab + Bag + Ppd + Exe + Dpb & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 + Inf2 + Ini2 + Cat2 + Gpd2 + Xml2 + Gdl2 + Js2 + Dpd2 + Cab2 + Bag2 + Ppd2 + Exe2 + Dpb2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 + Inf3 + Ini3 + Cat3 + Gpd3 + Xml3 + Gdl3 + Js3 + Dpd3 + Cab3 + Bag3 + Ppd3 + Exe3 + Dpb3 & "]"
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page29#post12484



' Macro to color text of matching files in two worksheets
Sub CompareDriverFilesCommandIndrivers() '
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim Wsdr As Worksheet, WsCmd As Worksheet
Set Wsdr = Worksheets("drivers"): Set WsCmd = Worksheets("PowerShell")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=drivers!D4:drivers!E180") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=drivers!D4"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Wsdr.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page29#post12485


' Macro to color text of matching files in two worksheets
Sub CompareDriverFilesCommandInDriverStore() '
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDS As Worksheet, WsCmd As Worksheet
Set WsDS = Worksheets("DriverStore"): Set WsCmd = Worksheets("PowerShell")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDS.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

In support of these threads.
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page30#post12493


http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page33#post12597


'
Sub CompareDriverFilesDeviceManagerInDoubleDriverAllLi st2()
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDDA As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDDA = Worksheets("DDAllBefore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DDAllBefore!F5:DDAllBefore!G670") ' WsDDA.Range("=F5:G670")
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!F5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDDA.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

















For
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page30#post12492

[DocAElstein]

In support of this post:
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page36#post12628

Note a new modification... for the case of when a cell in Device Manger is coloured ( indicating a match to drivers ) but the case when no match is found in DriverStore. We then need to make the underline which we are using as an indication for a match to drivers

Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If



Sub CompareDriverFilesDeviceManagerInDriverStore2() '
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDrSt As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDrSt = Worksheets("DriverStore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDMP.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
Do While Not FndCel Is Nothing ' Start Find next loop ======
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True

WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Set FndCel = Application.Range("=DriverStore!D" & FndCel.Row + 1 & ":DriverStore!F4437").Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!F4437"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '
Loop ' End Find next loop =================================
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page39#post12659





Sub FileTypesHereInDeviceManagerPropertiesUndDriverSto reUnddrivers2() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page39#post12659 http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page18#post12360
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(rngStr.Value, 3) = "C:\" And InStr(4, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(4, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
If rngStr.Font.Italic = True Then Let Sys2 = Sys2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1
If rngStr.Font.Italic = True Then Let Ddl2 = Ddl2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1
If rngStr.Font.Italic = True Then Let Bin2 = Bin2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1
If rngStr.Font.Italic = True Then Let Cpa2 = Cpa2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1
If rngStr.Font.Italic = True Then Let Vp2 = Vp2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1
If rngStr.Font.Italic = True Then Let Els2 = Els2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Els3 = Els3 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ") [" & Els3 & "]"

Debug.Print "Totals " & Sys + Ddl + Bin + Cpa + Vp + Els & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 & "]"
End Sub

[DocAElstein]

In support of this Thread answer
http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646


Option Explicit
Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDDD As Worksheet: Set WsDDD = Worksheets("DDAllEarlier_Marz17")
Dim RngDD As Range, rngDB As Range ' =ANZAHL2(B2:B550) 255 =ANZAHL2(D2:D550) 366
Set RngDD = WsDDD.Range("B2:B550"): Set rngDB = WsDDD.Range("D2:D550")
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
For Each Rng In RngDD '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDB.Find(what:=Rng.Value, After:=rngDB.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Font.Color = 0 Then ' case "virgin black" text
FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell text is already colored, so try again
Set FndRng = WsDDD.Range("D" & FndRng.Row + 1 & ":D550").Find(what:=Rng.Value, After:=WsDDD.Range("D550"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In RngDD ---------------|
End Sub

[DocAElstein]

In support of these posts
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12669
http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646


' _ Marz 2020
Sub DeviceManagerPropertiesMarz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDMP As Worksheet: Set WsDMP = Worksheets("DeviceManagerProperties")
Dim rngDMP1 As Range, rngDMP2 As Range ' B1:F550 G1:J550
Set rngDMP1 = WsDMP.Range("B5:F550"): Set rngDMP2 = WsDMP.Range("G5:J550")
' take each cell in range for original DMP and find it in range for new DMP but find next if the interior is already coloured
Dim Rng As Range
For Each Rng In rngDMP1 '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDMP2.Find(what:=Rng.Value, After:=rngDMP2.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Interior.ColorIndex = -4142 Then ' case "virgin "white"" text
FndRng.Select
Let FndRng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell already has background color, so try again from next row
Set FndRng = WsDMP.Range("G" & FndRng.Row + 1 & ":J550").Find(what:=Rng.Value, After:=WsDMP.Range("J550"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng '------------------------------------|

End Sub




ExplorerBefore DeviceManager Earlier and Marz17 2020.xlsm : https://app.box.com/s/gsgwwbqggel397ufnruegjyfst51p3g6

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12670



Option Explicit
' Marz 2020
Private Sub FileTypesHere_And_MaybeAlsoInDeviceManager()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E300") 'Set Rng = Ws.Range("F4:G300") ' Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Dim Dpb As Long, Ppd As Long
Dim Dpb2 As Long, Ppd2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' Dim Dpb As Long, Ppd As Long
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path, or rather not a . in
Dim Fldr As Long: Let Fldr = Fldr + 1
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' Dim Dpb As Long, Ppd As Long
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ")"
Debug.Print "Total files is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Dpb + Ppd
Debug.Print "Things with no . are " & Fldr
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12671


Option Explicit ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12671
Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDDD As Worksheet: Set WsDDD = Worksheets("DDAllComparison")
Dim RngDD1 As Range, RngDD2 As Range '
Set RngDD1 = WsDDD.Range("D4:E680"): Set RngDD2 = WsDDD.Range("F4:H680")
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
For Each Rng In RngDD1 '----------------------| looking at each cell in the newest range, trying to find it in the original range
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range ' FndRng, if found, is in RngDD2 , looking for value in each cell in RngDD1
Set FndRng = RngDD2.Find(what:=Rng.Value, After:=RngDD2.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Interior.ColorIndex = -4142 Then ' case "virgin "white"" text
FndRng.Select
Let FndRng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell text is already colored, so try again
Set FndRng = WsDDD.Range("F" & FndRng.Row + 1 & ":H680").Find(what:=Rng.Value, After:=WsDDD.Range("H680"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In RngDD1 ---------------|
End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672


' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672
' Set Rngdr1 = Wsdrs.Range("F2:H180"): Set Rngdr2 = Wsdrs.Range("C2:E180") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020
Private Sub FileTypesHereIndrivers_()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Worksheets("drivers marz 2020")
Dim Rng As Range: Set Rng = Ws.Range("C2:E180") ' Ws.Range("F2:H180") ' Ws.Range("C2:E180")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Dim Sam As Long
Dim Sam2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
Dim rngStr As Range
For Each rngStr In Rng
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot .
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim Xtn As String: Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot .
' this next section catches single . things
' If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single .
If Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) = 1 Then ' case a single .
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' sam
Case "SAM"
Let Sam = Sam + 1: If rngStr.Font.Color <> 0 Then Let Sam2 = Sam2 + 1
Case Else
Debug.Print "Case Else for single "" . "" " & rngStr.Value
Let Els = Els + 1
End Select
ElseIf Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui
' this next section catches double . . things
Dim DllMui As Long, SysMui As Long, Els2 As Long
Dim DllMui2 As Long, SysMui2 As Long
Select Case UCase(Xtn)
Case "DLL.MUI"
Let DllMui = DllMui + 1: If rngStr.Font.Color <> 0 Then Let DllMui2 = DllMui + 1
Case "SYS.MUI"
Let SysMui = SysMui + 1: If rngStr.Font.Color <> 0 Then Let SysMui2 = SysMui + 1
Case Else
Debug.Print "Case Else for double "" . . "" " & rngStr.Value
Let Els2 = Els2 + 1
End Select
ElseIf Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) > 2 Then
' this section catches strings with dots more than 2
Dim LtsDts As Long
Debug.Print "More than 2 dots -- " & rngStr.Value
Let LtsDts = LtsDts + 1
End If
Else ' not a file, ( well no . in it anyway )
Dim Fldr As Long
Debug.Print "Folder? " & rngStr.Value
Let Fldr = Fldr + 1
End If
End If
Next rngStr
' Next ClCnt
' Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "Else1 " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' sam
Debug.Print "sam " & Sam & " (" & Sam2 & ")"
' Dim DllMui As Long, SysMui As Long, Els2 As Long
Debug.Print "dll.mui " & DllMui & " (" & DllMui2 & ")"
Debug.Print "sys.mui " & SysMui & " (" & SysMui2 & ")"
Debug.Print "Else2 " & Els2
Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Bag2 + Xml2 + Js2 + Gdl2 + Cab2 + Ini2 + Cat2 + Inf2 + Pnf2 + Gpd2 + Exe2 + DllMui2 + SysMui2 + Sam2 & ")"
Debug.Print "Total Folders is " & Fldr
Debug.Print "Total things with more than 2 dots is " & LtsDts
End Sub

[DocAElstein]

In support of this post.
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672


Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020") ' C2:E180 F2:H180
Dim Rngdr1 As Range, Rngdr2 As Range '
Set Rngdr1 = Wsdrs.Range("F2:H180"): Set Rngdr2 = Wsdrs.Range("C2:E180") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
For Each Rng In Rngdr2 '----------------------| looking at each cell in the newest range, trying to find it in the original range
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range ' FndRng, if found, is in RngDD2 , looking for value in each cell in RngDD1
Set FndRng = Rngdr1.Find(what:=Rng.Value, After:=Rngdr1.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Interior.ColorIndex = -4142 Then ' case "virgin "white"" text
FndRng.Select
Let FndRng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell text is already colored, so try again
Set FndRng = Wsdrs.Range("F" & FndRng.Row + 1 & ":H180").Find(what:=Rng.Value, After:=Wsdrs.Range("H180"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In Rngdr2 ---------------|
End Sub

[DocAElstein]

In support of this post…


http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12673




' =ANZAHL2(H3:J4396) =ANZAHL2(D3:F4396) G3:J4396 C3:F4396
Private Sub FileTypesHereArraysNew()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("A1:F4397")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Sam As Long
Dim Inf_loc As Long, Hlp As Long, Ntf As Long, Ppd As Long, Tbl As Long, Icc As Long, Dat As Long
Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If ClCnt = 2 And arrFiles(RwCnt, ClCnt) <> "" Then ' case of folder path
Dim Fldr As Long ' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt)
Let Fldr = Fldr + 1
Let RwCnt = RwCnt + 1 ' this is naughty, but will stop us hitting the folder name as the columns increase
Else ' not a folder and if empty then not in column 2
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot .
' this next section catches single . things
If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single .
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
Case "DLL"
Let Ddl = Ddl + 1
Case "BIN"
Let Bin = Bin + 1
Case "CPA"
Let Cpa = Cpa + 1
Case "VP"
Let Vp = Vp + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1
Case "XML"
Let Xml = Xml + 1
Case "JS"
Let Js = Js + 1
Case "GDL"
Let Gdl = Gdl + 1
Case "CAB"
Let Cab = Cab + 1
Case "INI"
Let Ini = Ini + 1
Case "CAT"
Let Cat = Cat + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1
Case "PNF"
Let Pnf = Pnf + 1
Case "GPD"
Let Gpd = Gpd + 1
Case "EXE"
Let Exe = Exe + 1
' sam
Case "SAM"
Let Sam = Sam + 1
'inf_loc Pnf HLP NTF Ppd TBL ICC DAT
Case "INF_LOC"
Let Inf_loc = Inf_loc + 1
Case "HLP"
Let Hlp = Hlp + 1
Case "NTF"
Let Ntf = Ntf + 1
Case "PPD"
Let Ppd = Ppd + 1
Case "TBL"
Let Tbl = Tbl + 1
Case "ICC"
Let Icc = Icc + 1
Case "DAT"
Let Dat = Dat + 1
'Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Case "DPB"
Let Dpb = Dpb + 1
Case "CTY"
Let Cty = Cty + 1
Case "MSC"
Let Msc = Msc + 1
Case "XST"
Let Xst = Xst + 1
Case Else
Debug.Print "Case Else for single "" . "" " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui
' this next section catches double . . things
Dim DllMui As Long, SysMui As Long, Els2 As Long
Select Case UCase(Xtn)
Case "DLL.MUI"
Let DllMui = DllMui + 1
Case "SYS.MUI"
Let SysMui = SysMui + 1
Case Else
Debug.Print "Case Else for double "" . . "" " & arrFiles(RwCnt, ClCnt)
Let Els2 = Els2 + 1
End Select
ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) > 2 Then
' this section catches strings with dots more than 2
Dim LtsDts As Long
Debug.Print "More than 2 dots -- " & arrFiles(RwCnt, ClCnt)
Let LtsDts = LtsDts + 1
End If
Else ' not a file, ( well no . in it anyway )
' Dim Fldr As Long
' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt)
' Let Fldr = Fldr + 1
End If
End If ' end of case empty cell
End If ' end of folder is counted based on "G:\" in column B
Next ClCnt
Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys
Debug.Print "dll " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "Else1 " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag
Debug.Print "xml " & Xml
Debug.Print "js " & Js
Debug.Print "gdl " & Gdl
Debug.Print "cab " & Cab
Debug.Print "ini " & Ini
Debug.Print "cat " & Cat
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf
Debug.Print "pnf " & Pnf
Debug.Print "gpd " & Gpd
Debug.Print "exe " & Exe
' sam
Debug.Print "sam " & Sam
' inf_loc Pnf HLP NTF Ppd TBL ICC DAT
Debug.Print "inf_loc " & Inf_loc
Debug.Print "pnf " & Pnf
Debug.Print "hlp " & Hlp
Debug.Print "ntf " & Ntf
Debug.Print "ppd " & Ppd
Debug.Print "tbl " & Tbl
Debug.Print "icc " & Tbl
Debug.Print "dat " & Dat
' Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long
Debug.Print "dpb " & Dpb
Debug.Print "cty " & Cty
Debug.Print "msc " & Msc
Debug.Print "xst " & Xst
' Dim DllMui As Long, SysMui As Long, Els2 As Long
Debug.Print "dll.mui " & DllMui
Debug.Print "sys.mui " & SysMui
Debug.Print "Else2 " & Els2
Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam + Inf_loc + Hlp + Ntf + Ppd + Tbl + Icc + Dat + Dpb + Cty + Msc + Xst
Debug.Print "Total Folders is " & Fldr
Debug.Print "Total things with more than 2 dots is " & LtsDts
End Sub


ExplorerBefore DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/oy8pnuizk6xng1msqlsxho7l8e0bi0t8
Explorer Before DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/4zx7b8d2gwjix7u68zit6o22x7q0kwm2

[DocAElstein]

Test blog post, and function needed for other posts…


http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12673




Title….

I have sometimes needed to check for a specific file type in a list of files and folders. Often a simple search for the characters in the extension, ( for example .doc for a Word 2003 file )
I had a more difficult situation where with multiple file types and folders which included parts in the text string which could be mistakenly found in a search fir the extension part.

The logic behind the simple functions below is as follows.
A string is taken in, strIn.
The function contains a list of all extensions being searched for. If an extension is found in the supplied string, then that extension is the string returned by the function. ( The first character in the extension string will always be a . )
If no match is found then the string of
“0” & strIn ' note: that first character is a zero
is retuned

Notes:
In the list, the longest character length extension are at the beginning. This avoids a part of the longer character extension being mistaken as a shorter character extension, since the longest character length extensions will be detected firstly .




Sub TestieGetMyExtension()
MsgBox prompt:=GetMyExtension("a")
MsgBox prompt:=GetMyExtension("1394ohci.sys")
MsgBox prompt:=GetMyExtension("61883.inf_amd64_fb51a2f8b89aa4a7")
MsgBox prompt:=GetMyExtension("wiaky003.inf_loc")
MsgBox prompt:=GetMyExtension("acpi.PNF")
MsgBox prompt:=GetMyExtension("bcmwdidhdpcie.inf_amd64_977dcc915465b0e9")

End Sub
Public Function GetMyExtension(ByVal strIn As String) As String
Dim MyExts() As Variant
Let MyExts() = Array("inf_loc", "sys.mui", "dll.mui", "sys", "dll", "bin", "cpa", "bag", "xml", "gdl", "cab", "ini", "cat", "inf", "pnf", "gpd", "exe", "sam", "hlp", "ntf", "ppd", "tbl", "icc", "dat", "dpb", "cty", "msc", "xst", "vp", "js")
Dim Stear As Variant
For Each Stear In MyExts()
Dim Lenf As Long: Let Lenf = Len(Stear)
If Len(strIn) > Lenf + 1 Then ' Length of strIn must be at least 2 more characters longer than the extension from the array above , like x.sys so greater than the length of like the length of .sys which has the length of (length of sys )+1
Dim LstBt As String
Let LstBt = Right(strIn, Lenf)
If "." & UCase(LstBt) = "." & UCase(Stear) Then
Let GetMyExtension = Stear
Exit Function ' end of function with sucessful file type find - give file type to function return string value
Else
' not this file type in last characters
End If
Else
' then input string is too short to include the current extension string in Stear
End If
Next Stear
Let GetMyExtension = "0" & strIn ' This allows a simple check for like If Left(GetMyExstension(kjshdkjs,kiafh_.kjfh, 1)= 0 Then to determine if we have a file type like we want
End Function





Sub CountMissingFilesFromOriginalInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") ' =ANZAHL2(H3:J4396) =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range '
Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String
For Each Rng In RngDS1
If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
' Not empty cell And No interior colour And any file extension
Let Cnt1 = Cnt1 + 1
Else
If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
Let strRej = strRej & Rng.Value & vbCr & vbLf
Let cnt2 = cnt2 + 1
Else
End If
End If
Next Rng
MsgBox prompt:="Missing is " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is " & cnt2
Debug.Print "Missing is " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is " & cnt2
End Sub
Sub CountNewFilesFromInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") ' =ANZAHL2(H3:J4396) =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range '
Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String, strNew As String
For Each Rng In RngDS2
If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
' conditions to be met are not empty And no interior colour And any file extension
Let Cnt1 = Cnt1 + 1
Let strNew = strNew & Rng.Value & vbCr & vbLf
Else
If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
Let strRej = strRej & Rng.Value & vbCr & vbLf
Let cnt2 = cnt2 + 1
Else
End If
End If
Next Rng
MsgBox prompt:="New is " & Cnt1 & vbCr & vbLf & "New are " & strNew
Debug.Print "New is " & Cnt1 & vbCr & vbLf & "New are " & strNew
' MsgBox prompt:="Missing is " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is " & cnt2
' Debug.Print "Missing is " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is " & cnt2
End Sub








ExplorerBefore DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/oy8pnuizk6xng1msqlsxho7l8e0bi0t8
Explorer Before DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/4zx7b8d2gwjix7u68zit6o22x7q0kwm2

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675
First use of Dictionary alternative.
The following two macros give similar results. The first is the big Case Else macro and the second the first use of a Dictionary, Dik, alternative.


Option Explicit
' Marz 2020
Private Sub FileTypesHere_And_MaybeAlsoInDeviceManager()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E300") 'Set Rng = Ws.Range("F4:G300") ' Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Dim Dpb As Long, Ppd As Long
Dim Dpb2 As Long, Ppd2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' Dim Dpb As Long, Ppd As Long
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path, or rather not a . in
Dim Fldr As Long: Let Fldr = Fldr + 1
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' Dim Dpb As Long, Ppd As Long
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ")"
Debug.Print "Total files is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Dpb + Ppd
Debug.Print "Things with no . are " & Fldr
End Sub

Private Sub FilesTypeHereFromFunction()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim rng2BSrchd As Range: Set rng2BSrchd = Ws.Range("D4:E260")
Rem 2 A Dik for the extensions and count thereof
'2a) Make the Dik
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")
Dik.CompareMode = vbTextCompare ' make case insensitive, probably not necersary in our case as we do all comares at UCase to make it already case insensitive
'2b) Fill the Dik
Dim rngStr As Range
For Each rngStr In rng2BSrchd
If rngStr.Value = "" Then
' empty cell Do nothing
Else
Dim FkBk As String
Let FkBk = GetMeExtension(Trim(rngStr.Value))
If Left(FkBk, 1) = "0" Then
Dim Fldrs As String
Let Fldrs = Fldrs & rngStr.Value & vbCr & vbLf
Else ' we have an extension of a type we may or may not have had already
If Dik.Exists("" & FkBk & "") Then
Let Dik.Item("" & FkBk & "") = Dik.Item("" & FkBk & "") + 1 ' add to count of this extension, - the count is actually held as the item
Else
Dik.Add Key:="" & FkBk & "", Item:=1 ' I create an item who's key is the extension string, and make item the count of it, 1 here initially
End If
End If
End If

Next rngStr
'2c) output from Dik
Dim Kys() As Variant, Itms() As Variant
Let Kys() = Dik.Keys(): Let Itms() = Dik.Items()
Dim Cnt As Long
For Cnt = 0 To Dik.Count - 1 ' Note Dictionaries by default start at 0, but the count is the actual number, so Count-1 is the last indicee and 0 is the first
Debug.Print Kys()(Cnt) & " " & Itms()(Cnt)
Next Cnt

End Sub

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675



' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675
Sub NewCmdVNewDD() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
Set Rngcmd = Wscmd.Range("D4:E260")
If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison")
Dim RngDD As Range
Set RngDD = WsDD.Range("E4:E680")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
For Each Rng In Selection
If Rng <> "" Then
Dim FndRng As Range ' range file cell found in DD
Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
Wscmd.Activate: Rng.Select
Let Rng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Do While Not FndRng Is Nothing
WsDD.Activate: FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In RngDD ---------------|
End Sub

[DocAElstein]

Macro for this post solution, ( written by the son of God )
http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897



Sub conditionally_delete3() ' http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12893&viewfull=1#post12893
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Set Wb1 = Workbooks("STEP1U.xlsb") ' Workbooks("sample1.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Upstox\STEP1U.xlsb")
Set Ws1 = Wb1.Worksheets.Item(1) ' worksheet of first tab
Set Wb2 = Workbooks("1.xls") ' Workbooks("sample2.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws2 = Wb2.Worksheets.Item(1) ' worksheet of first tab
'1b Ranges
Dim Rng1A As Range, Rng2B As Range
Set Rng1A = Ws1.Range("A2:A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "")
Set Rng2B = Ws2.Range("B2:B" & Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row & "")

Rem 2 Delete an entire row in Ws2 if value in column B is not anywhere in column A of Ws1
Dim Rws As Long
For Rws = Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row To 2 Step -1
Dim rngFnd As Range
Set rngFnd = Rng1A.Find(what:=Ws2.Range("B" & Rws & "").Value, After:=Rng1A.Item(1), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
If rngFnd Is Nothing Then ' The value from column B in Ws2 was not found in column A of Ws1
Ws2.Range("B" & Rws & "").EntireRow.Delete Shift:=xlUp
Else
' The value from column B in Ws2 was found in column A of Ws1 so do nothing
End If
Next Rws

' Wb1.Save
' Wb1.Close
' Wb2.Save
' Wb2.Close
End Sub










1.xls: https://app.box.com/s/th2xzmkh7rnfr4qf4dho1kpgudndm073

[DocAElstein]

In support of these posts

http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12676
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12677
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12678



' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12676
Sub NewCmdVNewDD() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
Set Rngcmd = Wscmd.Range("D4:E260")
If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison")
Dim RngDD As Range
Set RngDD = WsDD.Range("E4:E680")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
For Each Rng In Selection
If Rng <> "" Then
Dim FndRng As Range ' range file cell found in DD
Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
Wscmd.Activate: Rng.Select
Let Rng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Do While Not FndRng Is Nothing
WsDD.Activate: FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In RngDD ---------------|
End Sub

' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12677
Sub NewCmdVNewdrivers() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
Set Rngcmd = Wscmd.Range("E4:F260")
If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020")
Dim Rngdrs As Range
Set Rngdrs = Wsdrs.Range("D6:E180")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
For Each Rng In Selection
If Rng <> "" Then
Dim FndRng As Range ' range file cell found in DD
Set FndRng = Rngdrs.Find(what:=Rng.Value, After:=Rngdrs.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
Wscmd.Activate: Rng.Select
Let Rng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Do While Not FndRng Is Nothing
Wsdrs.Activate: FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = Wsdrs.Range("D" & FndRng.Row + 1 & ":E180").Find(what:=Rng.Value, After:=Wsdrs.Range("E180"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In ---- ---------------|
End Sub



' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12678
Sub NewCmdVNewDriverStore() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
Set Rngcmd = Wscmd.Range("E4:F260")
If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020")
Dim RngDS As Range
Set RngDS = WsDS.Range("D6:F4395")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
For Each Rng In Selection
If Rng <> "" Then
Dim FndRng As Range ' range file cell found in DD
Set FndRng = RngDS.Find(what:=Rng.Value, After:=RngDS.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
Wscmd.Activate: Rng.Select
Let Rng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Do While Not FndRng Is Nothing
WsDS.Activate: FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = WsDS.Range("D" & FndRng.Row + 1 & ":F4395").Find(what:=Rng.Value, After:=WsDS.Range("F4395"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In RngDD ---------------|
End Sub

[DocAElstein]

http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897
Test blog

Loop backwards when deleting rows

Important notes in support of these posts: http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897
https://excelfox.com/forum/showthread.php/2582-delete-entire-row-by-vbA
https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files

When deleting rows, ( and when deleting things generally ) , in a Loop, we will usually need to loop backwards.
If we loop backwards, things “behind us” were already considered, and so no strange effects will be noticed if they are effected by further deletions:
If we Loop forwards , rows will shift up after a delete, and so when moving on a row we may miss a row that is needed to be deleted, or other strange effects may occur:
Due to the deletion, things “ahead of us” , which we have not yet considered, may change in some way. The row number or item number, etc., of something not yet considered may change: This can cause VBA to get confused. We may get the wrong results, or worse, cause some coding error:
At the start of a loop, the parameters such as start, stop, and increment are set. Changing these after the loop begins may cause problems. It is generally bad practice to change loop parameters after the loop begins and before the loop ends, especially if those parameters are to be further used before the loop ends.

For example, in the case of deleting things in a looping process, this may sometimes give us problems:

__For Cnt = 1 To 4 Step 1 ' __ 1 2 3 4

Usually, this alternative, would overcome problems:

__For Cnt = 4 To 1 Step -1 ' __ 4 3 2 1



Example

We want to delete rows based on value in column C, in the range A1:C4: If the value is Delete this row , then the entire row should be deleted

Before:-

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
111aDo not delete

212BDelete this row

313cDelete this row

414DDo not delete

5

6Original Range:-

711aDo not delete

812BDelete this row

913cDelete this row

1014DDo not delete

11
Worksheet: MySheet

So in the above example, we want to delete rows 2 and 3.

We could try this macro, but it gives the wrong results. At first glance we would expect it to work.
It loops through the rows, and deletes the row if the value in column C is Delete this row. One could be forgiven for thinking that it should work.


Option Explicit
Sub LoopForwardsToDeleteRows()
Rem 1 Worksheets info
Dim Wb As Workbook, Ws As Worksheet
Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1)

Rem 2 Loop to delete rows
Dim Rws As Long
For Rws = 1 To 4 ' 1 2 3 4
If Ws.Range("C" & Rws & "").Value = "Delete this row" Then
Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and Shift all rows above up to fill space
Else
' Do nothing
End If
Next Rws
End Sub

After running the above macro we have

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
111aDo not delete

213cDelete this row

314DDo not delete

4

5Original Range:-

611aDo not delete

712BDelete this row

813cDelete this row

914DDo not delete

10

11
Worksheet: MySheet

This is what goes on:
Nothing is done to the first row. No problems
The second row is deleted as expected, because cell C2 value was Delete this row
After the second row is deleted, the rows which were after the second row, are all shifted one row up so as to fill the space or “hole” left by the removed row. ( We cannot have a “black hole” in an Excel worksheet:. Excel does not allow this. – The spreadsheet cells are moved so as to “fill” the hole made by the deletion. “New” cells are added as necessary at the worksheet perimeter – In this case a new virgin row is added at the bottom of the worksheet )
The result of the second row being deleted, and the necessary shifting of cells to fill the “hole” which is done, is as follows:
Our original 4th row now becomes the 3rd row. That does not cause any problems.
Our original 3rd row now becomes the 2nd row. This is the problem. The second row has already been considered. It will not be considered again. The original 3rd row, ( now, as a result of the first deletion and cell shifting, the second row ) will not be considered. So it remains. It is not considered. It will therefore not be deleted.
When looping forward and deleting, rows not yet considered will be moved: This may cause problems.

The solution to the problem is to loop backwards. When looping backwards, if a row is deleted, then all rows “behind”/ “above” are shifted down. All those rows have already been considered, and either left as they are or deleted.
The next row to be considered, when looping backwards in a worksheet, will always be the next, not yet considered, row, regardless of whether the last row considered was deleted or not: None of the rows not yet considered have been shifted.
When looping backwards and deleting, rows not yet considered will not have been moved

So we try again

Before, ( as in previous example )

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
111aDo not delete

212BDelete this row

313cDelete this row

414DDo not delete

5

6Original Range:-

711aDo not delete

812BDelete this row

913cDelete this row

1014DDo not delete

11
Worksheet: MySheet

Macro: ( looping backwards )


Sub LoopBackwardsToDeleteRows()
Rem 1 Worksheets info
Dim Wb As Workbook, Ws As Worksheet
Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1)

Rem 2 Loop to delete rows
Dim Rws As Long
For Rws = 4 To 1 Step -1 ' 4 3 2 1
If Ws.Range("C" & Rws & "").Value = "Delete this row" Then
Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and Shift all rows above up to fill space
Else
' Do nothing
End If
Next Rws
End Sub

After:

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFG
111aDo not delete

214DDo not delete

3

4Original Range:-

511aDo not delete

612BDelete this row

713cDelete this row

814DDo not delete

9

10

11
Worksheet: MySheet


This time we have the correct results: Looping backwards gives correct results. Looping fowards may give incorrect results.

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2438-replace-the-entire-row

Before

_____ Workbook: sample1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1014
1030
955.5
998.45
957.4


3NSEADANIPORTSEQ
27.35
27.75
25.65
25.65
25.85


4
Worksheet: Tabelle1

_____ Workbook: sample2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1014
1030
955.5
998.45
957.4


3NSEADANIPORTSEQ
27.35
28
29
30
27.35


4
Worksheet: Tabelle2


If column H of sample2.xlsx matches with Column D then look column B data of sample2.xlsx and find that data in sample1.xlsx in column B and after getting that data in sample1.xlsx in column B , copy that entire row of sample1.xlsx and paste that in sample2.xlsx in the same row


Result:

_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

NSEACCEQ
1014
1030
955.5
998.45
957.4

NSEADANIPORTSEQ
27.35
27.75
25.65
25.65
25.85


Worksheet: Tabelle2

[DocAElstein]

In support of this Post:
http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014

Before:

_____ Workbook: sample1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1000
1030
955.5
998.45
957.4


3NSEADANIENTEQ
27.35
27.75
25.65
25.65
25.85


4NSEADANIPORTSEQ
259
259.6
244
248.2
251.3


5NSEADANIPOWEREQ5, 45, 55, 65, 75, 8


6NSEAMARAJABATEQ
459.8
482.25
445.1
439.35
455.35


7NSEAMBUJACEMEQ7, 47, 57, 67, 77, 8


8NSEAPOLLOHOSPEQ8, 48, 58, 68, 78, 8


9
Worksheet: anything

_____ Workbook: sample2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A

1SYMBOL


2ACC


3ADANIPORTS


4AMARAJABAT


5
Worksheet: anything

run macro:


' http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste/page2#post13014 http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014
' http://www.excelfox.com/forum/showthread.php/2445-copy-and-paste-by-vba http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014
Sub STEP6d() ' match column B of sample1.xlsx matches with column A of sample2.xlsx
' if it matches then copy paste the data from column D to column H to sample2.xlsx from column B
Dim Wb1 As Workbook, Wb2 As Workbook ' If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Set Wb1 = Workbooks("sample1.xlsx") ' Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Set Wb2 = Workbooks("sample2.xlsx") ' Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb") ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Wb1.Worksheets("anything") ' sheet name can be anything
'Set Ws1 = Wb1.Worksheets.Item(1)
Set Ws2 = Wb2.Worksheets("anything")
'Set Ws2 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long, Lr2 As Long ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count).End(xlUp).Row

Dim Cnt As Long
For Cnt = 2 To Lr2
Dim FndCel As Range ' http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-or-replace-entire-row?p=13007&viewfull=1#post13007
Dim rngSrch As Range '
Set rngSrch = Ws1.Range("B2:B" & Lr1 & "")
Set FndCel = rngSrch.Find(What:=Ws2.Range("A" & Cnt & "").Value, After:=Ws1.Range("B2"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
' The range to be copied is always offset by 0 rows and +2 column from the cell found, FndCel, in column B of sample1.xlsx . Its size will be 1 row and 5 columns
FndCel.Offset(0, 2).Resize(1, 5).Copy ' copy column D to column H
' paste the data from column D to column H to sample2.xlsx from column B
Ws2.Range("A" & Cnt & "").Offset(0, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Next Cnt
End Sub


After Result:-

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

1SYMBOL


2ACC
1000
1030
955.5
998.45
957.4


3ADANIPORTS
259
259.6
244
248.2
251.3


4AMARAJABAT
459.8
482.25
445.1
439.35
455.35


5
Worksheet: anything

[DocAElstein]

Macro for this Post
' http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste-by-VBA-based-on-criteria?p=13058&viewfull=1#post13058 http://www.excelfox.com/forum/showthread.php/2454-copy-and-paste-by-vba?p=13058#post13058



' http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste-by-VBA-based-on-criteria?p=13058&viewfull=1#post13058 http://www.excelfox.com/forum/showthread.php/2454-copy-and-paste-by-vba?p=13058#post13058
Sub Step10()
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook ' If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Set Wb1 = Workbooks("1.xlsx") ' Workbooks("sample1.xlsx") ' Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Set Wb2 = Workbooks("2.xlsx") ' Workbooks("sample2.xlsx") ' Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb") ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ")
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1) ' Set Ws1 = Wb1.Worksheets("anything") ' sheet name can be anything
Set Ws2 = Wb2.Worksheets.Item(1) ' ' Set Ws2 = Wb2.Worksheets("anything")
Dim Lr1 As Long, Lc1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Lc1 = Ws1.Cells.Item(2, Ws1.Columns.Count).End(xlToLeft).Column
Rem 2 Data ranges
Dim arrOut() As String
ReDim arrOut(1 To Lr1 - 1, 1 To 2) ' A 2 column array of as many rows as data in 1.xlsx We may not need all the rows
Dim rngIn As Range
Set rngIn = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr1, Lc1))
Rem 3 Go through rows and columns in input data range
Dim Rws As Long
For Rws = 2 To Lr1 ' Go through rows in input data range
Dim rngInRws As Range
Set rngInRws = rngIn.Rows.Item(Rws) ' consider a row in the data range
Dim Clms As Long ' go through columns in each row
For Clms = 2 To Lc1 ' considering each column in the row under consideration
If rngInRws.Cells.Item(Clms).Interior.Color = 65535 And rngInRws.Cells.Item(Clms).Value >= 5 Then ' ...if yellow highlighted colour data is greater than 5 or equal to 5 then
Dim RwOut As Long ' a row in output array
Let RwOut = RwOut + 1 ' a next new row in output array
Let arrOut(RwOut, 1) = rngInRws.Cells.Item(1) ' The value in the first cell in the row under consideration is put in first column in output array
Let arrOut(RwOut, 2) = rngInRws.Cells.Item(Clms).Value ' The value in the highlighted cell in the row under consideration is put in the second column of the output array
Else
' Do nothing
End If
Next Clms
Next Rws
Rem 4 Output result
Let Ws2.Range("A1:B" & Lr1 - 1 & "").Value = arrOut() ' A range of the dimensions of the output array has its values assigned to the values in the output arry
End Sub

[DocAElstein]

In support of this question
https://excelribbon.tips.net/T008884_Condensing_Multiple_Worksheets_Into_One.ht ml


The full syntax of what Allen Wyatt is using is like …….
Cells(Rows.Count, 1).End(xlUp).Item(2) ……..
….
Item(2) will give us the cell just below the cell given by…….
Cells(Rows.Count, 1).End(xlUp) ………

Cells(Rows.Count, 1).End(xlUp) is the same as Cells(Rows.Count, 1).End(xlUp).Item(1) ………
……….
It is not to easy to explain how the items are assigned for a range……
See this demo


In the following demo, I show the item numbers for cells in four arbritrary ranges, A9 , B2:C3 , E5:G5 and D10:D12
As you will see, Item numbers are not restricted to just the range itself. The item numbers keep going. They go in a sequence of ... all columns in a row, ... then the next row ... etc....
The column count is determined by the original range, but the rows are not limited.


Row\Col
A
B
C
D
E
F
G

1


2Item(1)Item(2)


3Item(3)Item(4)


4Item(5)Item(6)


5Item(7)Item(8)Item(1)Item(2)Item(3)


6Item(9)….etc…Item(4)Item(5)Item(6)


7Item(7)Item(8)Item(9)


8Item(10)….etc….


9Item(1)


10Item(2)Item(1)


11Item(3)Item(2)


12Item(4)Item(3)


13Item(5)Item(4)


14Item(6)Item(5)


15…..etc….Item(6)


16Item(7)


17Item(8)


18Item(9)


19Item(10)


20….etc…


21

[DocAElstein]

test Evaluate range for this post
http://www.excelfox.com/forum/showthread.php/2456-Remove-decimals-by-vba

We can find the position of the . using Instr function https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/instr-function

Then we can take the left of the number for a length equal to the position of the . + 3 using the Left function https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/left-function

Then we can remove the . using the Replace function , https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/replace-function


or formulas...

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
K
L
M
N

2
1090.699


3
147.965


4
264.4785


5
30.2495


6


7


8
51090.69109069


9
4147.9614796


10
4264.4726447


11
330.243024


12


13
1090.699


14
147.965


15
264.4785


16
30.2495
Worksheet: 1-Sheet1
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
K
L
M
N

2
1090.699


3
147.965


4
264.4785


5
30.2495


6


7


8
=FIND(".",K2)=LEFT(K2,L8+2)=SUBSTITUTE(M8,".","")


9
=FIND(".",K3)=LEFT(K3,L9+2)=SUBSTITUTE(M9,".","")


10
=FIND(".",K4)=LEFT(K4,L10+2)=SUBSTITUTE(M10,".","")


11
=FIND(".",K5)=LEFT(K5,L11+2)=SUBSTITUTE(M11,".","")


12


13
1090.699


14
147.965


15
264.4785


16
30.2495
Worksheet: 1-Sheet1
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
L
M
N
O

8
=FIND(".",K2)=LEFT(K2,L8+2)=SUBSTITUTE(M8,".","")=SUBSTITUTE(LEFT(K2,FIND(".",K2)+2),".","")


9
=FIND(".",K3)=LEFT(K3,L9+2)=SUBSTITUTE(M9,".","")=SUBSTITUTE(LEFT(K3,FIND(".",K3)+2),".","")


10
=FIND(".",K4)=LEFT(K4,L10+2)=SUBSTITUTE(M10,".","")=SUBSTITUTE(LEFT(K4,FIND(".",K4)+2),".","")


11
=FIND(".",K5)=LEFT(K5,L11+2)=SUBSTITUTE(M11,".","")=SUBSTITUTE(LEFT(K5,FIND(".",K5)+2),".","")
Worksheet: 1-Sheet1

from Forulas, Evaluate Range

Sub EvaluateRangeTrimRemoveDot() ' http://www.excelfox.com/forum/showthread.php/2456-Remove-decimals-by-vba?p=13068#post13068
Dim Ws1 As Worksheet
Set Ws1 = Workbooks("1.xls").Worksheets.Item(1) ' First worksheet in open workbooks 1.xls
Dim LrK As Long: Let LrK = Ws1.Range("K" & Ws1.Rows.Count & "").End(xlUp).Row
Dim RngK As Range: Set RngK = Ws1.Range("K2:K" & LrK & "")
Let RngK.Value = Evaluate("=if({1},SUBSTITUTE(LEFT(" & RngK.Address & ",FIND("".""," & RngK.Address & ")+2),""."",""""))")
End Sub

[DocAElstein]

in support of this forum post
http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13088&viewfull=1#post13088


Explanation 1
In column K are numbers given to a maximum of 2 decimal places, for example
Column K
1090.69
147.95
264.47
30

The value in Column K must be adjusted so that it has the decimal format to 2 decimal places in steps of .05
So in this form, of like
…… 23.95 234 34.25 4.30 100.35 45.45 56.05 ……… etc….

So for example, in the above Column K test data, no adjustment is needed for 147.95 or 30
For 1090.69 and 264.47 some adjustment is needed. The adjustment could be to raise or lower the value. These are the possibilities:
change 1090.69 to 1090.65 or 1090.7
change 264.47 to 264.45 or 264.50

Which of the two adjustments is necessary will depend on the following:
If column H is greater than column D , then we adjust up .
If column H is lower than column D, then we adjust down .

Explanation 2
For all data rows, we compare column H to column D. If column H is greater than column D , then we adjust the value in column K up to the nearest multiple of .05. If column H is less than column D , then we adjust the value in column K down to the nearest multiple of .05. ( If the value in column K is an exact multiple of .05, then no action is to be taken )

For example
Before:
Row\Col
D
E
F
G
H
I
J
K

2
1087
1088
1077.25
1067.25
1079.9
25
10.799
1090.69


3
148.05
149.9
146.5
146
146.5
22
1.465
147.95


4
265
269.3
265
262.85
267.15
15083
2.6715
264.47


5
30.4
30.4
29.8
29.65
29.95
17388
0.2995
30


After:
Row\Col
D
E
F
G
H
I
J
K
L

2
1087
1088
1077.25
1067.25
1079.9
25
10.799
1090.65This nuber is adjusted down


3
148.05
149.9
146.5
146
146.5
22
1.465
147.95This number is not changed


4
265
269.3
265
262.85
267.15
15083
2.6715
264.5This number is adjusted up


5
30.4
30.4
29.8
29.65
29.95
17388
0.2995
30This number is not changed





Solution ( guess )

The previous formula solution already always adjust number down,


Row\Col
D
H
K
L
M
N
O
P

2
1087
1079.9
1090.69
21813.8
21813
1090.65
1090.65
1090.65


3
148.05
146.5
147.95
2959
2959
147.95
147.95
147.95


4
265
267.15
264.47
5289.4
5289
264.45
264.45
264.45


5
30.4
29.95
30
600
600
30
30
30

Row\Col
D
H
K
L
M
N
O
P

2
1087
1079.9
1090.69
=K2*100/5
=INT(L2)
=M2*5/100
=INT(L2)*5/100
=INT(K2*100/5)*5/100


3
148.05
146.5
147.95
=K3*100/5
=INT(L3)
=M3*5/100
=INT(L3)*5/100
=INT(K3*100/5)*5/100


4
265
267.15
264.47
=K4*100/5
=INT(L4)
=M4*5/100
=INT(L4)*5/100
=INT(K4*100/5)*5/100


5
30.4
29.95
30
=K5*100/5
=INT(L5)
=M5*5/100
=INT(L5)*5/100
=INT(K5*100/5)*5/100


So previous solution is correct if H < D
If H > D , the previous solution is .05 too small , so previous solution must be adjusted by +.05


=IF(H2<D2,INT(K2*100/5)*5/100,IF(H2>D2,(INT(K2*100/5)*5/100)+0.05,"H is equal to D"))


=IF(H3<D3,INT(K3*100/5)*5/100,IF(H3>D3,(INT(K3*100/5)*5/100)+0.05,"H is equal to D"))


=IF(H4<D4,INT(K4*100/5)*5/100,IF(H4>D4,(INT(K4*100/5)*5/100)+0.05,"H is equal to D"))


=IF(H5<D5,INT(K5*100/5)*5/100,IF(H5>D5,(INT(K5*100/5)*5/100)+0.05,"H is equal to D"))


But we must also check if number is already exact multiple of .05
Like if ( integer (value/.05)) – value/.05) = 0
( Excel has errors and bugs, and may give a very small number when it should give us 0, so we must do a trick-
if Round ( ( integer (value/.05)) – value/.05) ) = 0 )
So:


=IF(ROUND(INT(K2/0.05)-(K2/0.05),2)=0,K2,IF(H2<D2,INT(K2*100/5)*5/100,IF(H2>D2,(INT(K2*100/5)*5/100)+0.05,"H is equal to D")))


=IF(ROUND(INT(K3/0.05)-(K3/0.05),2)=0,K3,IF(H3<D3,INT(K3*100/5)*5/100,IF(H3>D3,(INT(K3*100/5)*5/100)+0.05,"H is equal to D")))


=IF(ROUND(INT(K4/0.05)-(K4/0.05),2)=0,K4,IF(H4<D4,INT(K4*100/5)*5/100,IF(H4>D4,(INT(K4*100/5)*5/100)+0.05,"H is equal to D")))


=IF(ROUND(INT(K5/0.05)-(K5/0.05),2)=0,K5,IF(H5<D5,INT(K5*100/5)*5/100,IF(H5>D5,(INT(K5*100/5)*5/100)+0.05,"H is equal to D")))



1090.65


147.95


264.5


30

[DocAElstein]

VBA Solution to above, and answer to this Post
http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13102&viewfull=1#post13102

VBA answer

Put columns in arrays
Row\Col
D

1Open


2
1087


3
148.05


4
265


5
30.4

arrD() =


1087


148.05


265


30.4



Row\Col
H

1LTP


2
1079.9


3
146.5


4
267.15


5
29.95

arrH() =


1079.9


146.5


267.15


29.95



Row\Col
K

1


2
1090.69


3
147.95


4
264.47


5
30

arrK() ( initial ) =


1090.69


147.95


264.47


30


The macro below manipulates the contents of arrK() as per the question requirement, then pastes the modified array over the initial values


Sub ChangeSecondNumberAfterDecimalConditionally() ' http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally
Rem 1 Worksheets info
Dim Wb1 As Workbook
Set Wb1 = Workbooks("SAMPLE1 18Apr2020.xlsx") ' Workbooks("1.xls") ' CHANGE TO SUIT
Dim Ws1 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Dim Lrow As Long
Let Lrow = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Rem 2 ranges of interest, D H and K , are placed in 1 column arrays, rows from 2 to Lrow
Dim arrD() As Variant, arrH() As Variant, ArrK() As Variant ' The .Value property used below returns its values in a field of variant type elements, so to avoiud a type mismatch we must Dim here appropriately
Let arrD() = Ws1.Range("D2:D" & Lrow & "").Value: Let arrH() = Ws1.Range("H2:H" & Lrow & "").Value: Let ArrK() = Ws1.Range("K2:K" & Lrow & "").Value
Rem 3 Manipulate arrK() as per requiremnt For all data rows, we compare column H to column D. If column H is greater than column D , then we adjust the value in column K up to the nearest multiple of .05. If column H is less than column D , then we adjust the value in column K down to the nearest multiple of .05. ( If the value in column K is an exact multiple of .05, then no action is to be taken ) http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13099&viewfull=1#post13099
Dim Cnt
For Cnt = 1 To Lrow - 1 ' range is row 2 to Lrow-1, array will be 1 to Lrow-1
If Int(Round((ArrK(Cnt, 1) / 0.05), 2)) - Round((ArrK(Cnt, 1) / 0.05), 2) = 0 Then
' do nothing because we have exact mulktiple of .05
Else ' case K is not an exact multiple of .05
If arrH(Cnt, 1) < arrD(Cnt, 1) Then
Let ArrK(Cnt, 1) = Int(ArrK(Cnt, 1) * 100 / 5) * 5 / 100 ' =INT(K2*100/5)*5/100 =K2*100/5 =INT(L2) =M2*5/100 =INT(L2)*5/100 =INT(K2*100/5)*5/100 http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13100&viewfull=1#post13100
ElseIf arrH(Cnt, 1) > arrD(Cnt, 1) Then
Let ArrK(Cnt, 1) = (Int(ArrK(Cnt, 1) * 100 / 5) * 5 / 100) + 0.05
Else ' case H = D
Let ArrK(Cnt, 1) = "H is equal to D"
End If
End If
Next Cnt
Rem 4 Paste out modified array over original values
Let Ws1.Range("K2:K" & Lrow & "").Value = ArrK()
End Sub

After running that macro the arrK() contents change to


1090.65


147.95


264.5


30


And that is then pasted out into the range
Row\Col
K

1


2
1090.65


3
147.95


4
264.5


5
30

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba

1.xls

A B C D E F G H I J K L

Exchange Symbol Series/Expiry Open High Low Prev Close LTP
NSE ACC EQ 1182 1193 1151.7 1156.6 1156.6 22 11.566 116815 1168.166
NSE ADANIENT EQ 137.15 140.55 134.1 134.65 134.65 25 1.3465 13595 135.9965
NSE ADANIPORTS EQ 273.95 276.95 269.55 270.65 270.65 15083 2.7065 27335 273.3565
NSE ADANIPOWER EQ 32.3 32.35 30.45 30.65 30.65 17388 0.3065 3095 30.9565
NSE AMARAJABAT EQ 555 555 529.25 532.1 532.1 100 5.321 5374 537.421
NSE ASIANPAINT EQ 1815.05 1842.8 1814 1827.55 1827.55 236 18.2755 18093 1809.2745
NSE AMBUJACEM EQ 169.9 171.6 166.2 167.95 167.95 1270 1.6795 1696 169.6295
NSE APOLLOHOSP EQ 1360 1377.5 1341.1 1359.5 1359.5 157 13.595 137305 1373.095
NSE APOLLOPIPE EQ 277.55 284 277.4 280.15 280.15 14361 2.8015 27735 277.3485
NSE ASHOKLEY EQ 46 46.3 44.6 44.95 44.95 212 0.4495 4535 45.3995
NSE AUROPHARMA EQ 629.05 654.5 618.5 624.45 624.45 275 6.2445 63065 630.6945
NSE AXISBANK EQ 416 419.65 401.25 403.95 403.95 5900 4.0395 40795 407.9895
NSE BAJAJ-AUTO EQ 2410 2472 2381 2445.35 2445.35 16669 24.4535 24209 2420.8965
NSE BAJAJFINSV EQ 4675 4675 4365 4389.8 4389.8 16675 43.898 443365 4433.698
NSE BAJFINANCE EQ 2113.5 2113.5 1970.05 1976.25 1976.25 317 19.7625 199601.25 1996.0125
NSE BALKRISIND EQ 879 887.5 856.7 867.75 867.75 335 8.6775 8764 876.4275
NSE BANKBARODA EQ 47.65 48 46.1 46.35 46.35 4668 0.4635 468 46.8135
NSE BATAINDIA EQ 1258 1313 1230 1239.55 1239.55 371 12.3955 12519 1251.9455
NSE BEL EQ 75.1 77.7 73.35 74.55 74.55 383 0.7455 7525 75.2955
NSE BERGEPAINT EQ 521 535 515 519.7 519.7 404 5.197 52485 524.897
NSE BHARATFORG EQ 251.1 265 251.1 263.25 263.25 422 2.6325 26065 260.6175
NSE BHARTIARTL EQ 494.9 499 484.45 494.25 494.25 10604 4.9425 49915 499.1925
NSE BHEL EQ 21.1 21.4 20.6 20.65 20.65 438 0.2065 2085 20.8565
NSE BIOCON EQ 346 360 339 357.4 357.4 11373 3.574 35385 353.826
NSE BOSCHLTD EQ 10470 10500 10100 10212.45 10212.45 2181 102.1245 1031455 10314.5745
NSE BPCL EQ 352 356.65 347 350.45 350.45 526 3.5045 35395 353.9545
NSE BRITANNIA EQ 2980 3122.9 2956 3062.15 3062.15 547 30.6215 303155 3031.5285
NSE CADILAHC EQ 333.25 344 330.9 336.95 336.95 7929 3.3695 3336 333.5805
NSE CANBK EQ 82.55 84.7 81.05 81.35 81.35 10794 0.8135 8215 82.1635
NSE CASTROLIND EQ 124.15 127 119.3 120.7 120.7 1250 1.207 1219 121.907
NSE CENTURYTEX EQ 289.2 298.5 282 284.05 284.05 625 2.8405 28685 286.8905
NSE CESC EQ 603 609.5 590.95 596.75 596.75 628 5.9675 6027 602.7175
NSE CHOLAFIN EQ 145 145.8 132.05 132.9 132.9 685 1.329 1342 134.229
NSE CIPLA EQ 586.4 606 583.6 599.3 599.3 694 5.993 59335 593.307
NSE COALINDIA EQ 140.6 143.8 135.8 137 137 20374 1.37 13835 138.37
NSE COLPAL EQ 1470 1497.95 1463.6 1483.65 1483.65 15141 14.8365 146885 1468.8135
NSE CONCOR EQ 368 376.6 359.5 361.1 361.1 4749 3.611 3647 364.711
NSE CUMMINSIND EQ 420.95 426.55 377.25 384.95 384.95 1901 3.8495 38875 388.7995
NSE DABUR EQ 499 503.75 494.5 499.05 499.05 772 4.9905 4941 494.0595
NSE DISHTV EQ 5.1 5.15 4.75 4.75 4.75 0.0475 475 4.7975
NSE DIVISLAB EQ 2410 2460 2390.6 2425.4 2425.4 10940 24.254 240115 2401.146
NSE DLF EQ 135 135 127.6 128.2 128.2 14732 1.282 12945 129.482
NSE DRREDDY EQ 4010 4049.6 3970.1 4002.8 4002.8 881 40.028 40428 4042.828
NSE EICHERMOT EQ 14068 14091 13505.1 13589.2 13589.2 910 135.892 1372505 13725.092
NSE EQUITAS EQ 53.85 56.4 50.65 51.05 51.05 16852 0.5105 5155 51.5605
NSE ESCORTS EQ 744 758.7 712.2 717 717 958 7.17 72415 724.17
NSE EXIDEIND EQ 146.3 151.8 145.15 148.45 148.45 676 1.4845 14696.55 146.9655
NSE FEDERALBNK EQ 44 44.2 42.9 43.1 43.1 1023 0.431 435 43.531
NSE GAIL EQ 82.95 84.25 79 81.5 81.5 4717 0.815 823 82.315
NSE GLENMARK EQ 342.7 360.95 342 344.85 344.85 7406 3.4485 34145 341.4015
NSE GMRINFRA EQ 17.5 17.5 17 17.15 17.15 13528 0.1715 173 17.3215
NSE GODREJCP EQ 536.95 547.1 530.05 534.4 534.4 10099 5.344 5397 539.744
NSE GRASIM EQ 492 501.9 484.75 499.05 499.05 1232 4.9905 4941 494.0595
NSE HAVELLS EQ 524 537 517.1 525.6 525.6 9819 5.256 52035 520.344
NSE HCLTECH EQ 480 496.9 465.15 468.1 468.1 7229 4.681 47275 472.781
NSE HDFC EQ 1603 1624.95 1569.1 1580.3 1580.3 1330 15.803 15961 1596.103
NSE HDFCBANK EQ 933 958.4 926 938.05 938.05 1333 9.3805 9287 928.6695
NSE HEROMOTOCO EQ 1842.5 1939.4 1840 1894.8 1894.8 1348 18.948 18759 1875.852
NSE HINDALCO EQ 109.95 109.95 102.85 103.65 103.65 1363 1.0365 10465 104.6865
NSE HINDPETRO EQ 208.75 208.75 200 201.4 201.4 1406 2.014 2034 203.414
NSE HINDUNILVR EQ 2311 2338 2280 2283.1 2283.1 1394 22.831 23059 2305.931
NSE IBULHSGFIN EQ 114 118.4 111 112.95 112.95 30125 1.1295 11405 114.0795
NSE ICICIBANK EQ 337.9 343.25 331.5 334.85 334.85 4963 3.3485 33815 338.1985
NSE ICICIPRULI EQ 348 356.8 329.4 336.55 336.55 18652 3.3655 3399 339.9155
NSE IDEA EQ 4.25 4.25 3.95 4 4 14366 0.04 404 4.04
NSE IDFCFIRSTB EQ 23.35 23.4 22.1 22.2 22.2 11184 0.222 224 22.422
NSE IGL EQ 446 455.7 430 437.25 437.25 11262 4.3725 4416 441.6225
NSE INDIGO EQ 930 938.55 878.75 891.75 891.75 11195 8.9175 90065 900.6675
NSE INDUSINDBK EQ 392.25 399.9 380 382.9 382.9 5258 3.829 3867 386.729
NSE INFRATEL EQ 169 172.9 149.5 152 152 29135 1.52 1535 153.52
NSE INFY EQ 668.55 675 654.8 658 658 1594 6.58 66455 664.58
NSE IOC EQ 82.25 84.4 81.1 81.5 81.5 1624 0.815 823 82.315
NSE ITC EQ 181 182.8 179.3 180.05 180.05 1660 1.8005 18185 181.8505
NSE JINDALSTEL EQ 85 87 78.25 79.15 79.15 6733 0.7915 799 79.9415
NSE JSWSTEEL EQ 157.5 159.5 152.6 153.25 153.25 11723 1.5325 15475 154.7825
NSE JUBLFOOD EQ 1484 1494.7 1444.45 1478.7 1478.7 18096 14.787 149345 1493.487
NSE JUSTDIAL EQ 343 349.85 327 329.8 329.8 29962 3.298 33305 333.098
NSE KOTAKBANK EQ 1219 1258 1213.35 1239.55 1239.55 1922 12.3955 12272 1227.1545
NSE L&TFH EQ 58.5 60.2 58.05 58.95 58.95 24948 0.5895 584 58.3605
NSE LICHSGFIN EQ 280 281 259.15 260.65 260.65 1997 2.6065 26325 263.2565
NSE LT EQ 838 869 834.15 851.2 851.2 11483 8.512 8427 842.688
NSE LUPIN EQ 824.7 891 820.7 877.35 877.35 10440 8.7735 8686 868.5765
NSE M&M EQ 342 344.75 332 334.3 334.3 2031 3.343 3376 337.643
NSE M&MFIN EQ 150 150 138.2 140.45 140.45 13285 1.4045 14185 141.8545
NSE MANAPPURAM EQ 106 108.1 104.05 107.1 107.1 19061 1.071 10605 106.029
NSE MARICO EQ 300.9 309.55 300 306.1 306.1 4067 3.061 30305 303.039
NSE MARUTI EQ 5100 5140 5030 5045.65 5045.65 10999 50.4565 50961 5096.1065
NSE MCDOWELL-N EQ 524.9 527.9 516.7 519.5 519.5 10447 5.195 52465 524.695
NSE MFSL EQ 415 432.75 400.55 420.15 420.15 2142 4.2015 41595 415.9485
NSE MGL EQ 912 936.95 890 913.05 913.05 17534 9.1305 90395 903.9195
NSE MINDTREE EQ 770.75 785 755 780.35 780.35 14356 7.8035 77255 772.5465
NSE MOTHERSUMI EQ 72.4 74.25 71.35 72 72 4204 0.72 727 72.72
NSE MRF EQ 58225 59200 58000 58805.4 58805.4 2277 588.054 5821735 58217.346
NSE MUTHOOTFIN EQ 809.4 834 798.05 813.95 813.95 23650 8.1395 80585 805.8105
NSE NATIONALUM EQ 33.75 34.9 30.55 31.5 31.5 6364 0.315 318 31.815
NSE NBCC EQ 20.5 20.6 18.9 19.25 19.25 31415 0.1925 194 19.4425
NSE NCC EQ 25.45 25.8 24.4 24.6 24.6 2319 0.246 248 24.846
NSE NESTLEIND EQ 17300 17800 17300 17406.05 17406.05 17963 174.0605 1723198.95 17231.9895
NSE NIITTECH EQ 1181 1199 1085.25 1116.1 1116.1 11543 11.161 112725 1127.261
NSE NMDC EQ 76.7 77.9 73.4 73.8 73.8 15332 0.738 745 74.538
NSE NTPC EQ 94.75 96.35 91.95 93.4 93.4 11630 0.934 943 94.334
NSE OIL EQ 86 88.6 83.5 83.85 83.85 17438 0.8385 8465 84.6885
NSE ONGC EQ 67.15 69.5 66.6 67.6 67.6 2475 0.676 6695 66.924
NSE PAGEIND EQ 17550 17970 17460 17854.35 17854.35 14413 178.5435 1767585 17675.8065
NSE PEL EQ 815 877.45 808.1 864.45 864.45 2412 8.6445 85585 855.8055
NSE PETRONET EQ 220 222.95 215.75 218.5 218.5 11351 2.185 22065 220.685
NSE PFC EQ 90.7 94.35 89.6 91.05 91.05 14299 0.9105 9015 90.1395
NSE PIDILITIND EQ 1532.1 1576.8 1500.15 1505.2 1505.2 2664 15.052 152025 1520.252
NSE PNB EQ 30.7 31.1 30.15 30.2 30.2 10666 0.302 305 30.502
NSE POWERGRID EQ 157 160.1 155.75 159.15 159.15 14977 1.5915 1576 157.5585
NSE PVR EQ 973 989.4 950 954.6 954.6 13147 9.546 9641 964.146
NSE RAMCOCEM EQ 569.5 584.4 534 538.05 538.05 2043 5.3805 5434 543.4305
NSE RBLBANK EQ 104.5 110.7 101.7 107.15 107.15 18391 1.0715 1061 106.0785
NSE RECLTD EQ 90.65 93.4 89.1 89.35 89.35 15355 0.8935 902 90.2435
NSE RELIANCE EQ 1350.15 1494.95 1347.2 1417 1417 2885 14.17 140285 1402.83
NSE SAIL EQ 26 27.35 25.8 26.9 26.9 2963 0.269 2665 26.631
NSE SBIN EQ 184 184 179 179.75 179.75 3045 1.7975 1815 181.5475
NSE SHREECEM EQ 18739 18927.3 18382.55 18587.45 18587.45 3103 185.8745 187733 18773.3245
NSE SIEMENS EQ 1159 1203.7 1135 1145.9 1145.9 3150 11.459 115735 1157.359
NSE SRF EQ 3602 3660.8 3470 3488.05 3488.05 3273 34.8805 35229 3522.9305
NSE SRTRANSFIN EQ 610 699 579.25 668.2 668.2 4306 6.682 66155 661.518
NSE SUNPHARMA EQ 476.95 497 473.55 485.55 485.55 3351 4.8555 4807 480.6945
NSE SUNTV EQ 368.7 385.45 366.5 376.9 376.9 13404 3.769 37315 373.131
NSE TATACHEM EQ 263.4 273 255.35 270.05 270.05 3405 2.7005 26735 267.3495
NSE TATAMOTORS EQ 75 76.9 74 74.2 74.2 3456 0.742 749 74.942
NSE TATAMTRDVR EQ 34.3 34.95 33.5 33.7 33.7 16965 0.337 3403.7 34.037
NSE TATAPOWER EQ 32.6 32.6 30.8 31.05 31.05 3426 0.3105 3135 31.3605
NSE TATASTEEL EQ 266.3 273.85 264.45 267.55 267.55 3499 2.6755 2649 264.8745
NSE TCS EQ 1840.7 1851.95 1807.8 1818.55 1818.55 11536 18.1855 18367 1836.7355
NSE TECHM EQ 522 532.6 502.1 503.45 503.45 13538 5.0345 50845 508.4845
NSE TITAN EQ 910 926.9 893.1 906.05 906.05 3506 9.0605 9151 915.1105
NSE TORNTPHARM EQ 2430 2488 2361.65 2430.5 2430.5 3518 24.305 24062 2406.195
NSE TORNTPOWER EQ 297.5 307.9 296.65 303.8 303.8 13786 3.038 3008 300.762
NSE TVSMOTOR EQ 298 302 289.05 297 297 8479 2.97 29995 299.97
NSE UBL EQ 921 922.5 863.85 880.75 880.75 16713 8.8075 88955 889.5575
NSE UJJIVAN EQ 170 173.5 161.6 164.1 164.1 17069 1.641 1657 165.741
NSE ULTRACEMCO EQ 3410 3440 3292.8 3307.95 3307.95 11532 33.0795 334102.95 3341.0295
NSE UPL EQ 345 347.6 334.2 335.85 335.85 11287 3.3585 3392 339.2085
NSE VEDL EQ 76.8 80.25 75.7 77.95 77.95 3063 0.7795 772 77.1705
NSE VOLTAS EQ 500 505 485 487.15 487.15 3718 4.8715 49202.15 492.0215
NSE WIPRO EQ 179.95 180.8 177.15 177.75 177.75 3787 1.7775 1795 179.5275
NSE ZEEL EQ 150.8 152.85 143 145.15 145.15 3812 1.4515 1466 146.6015

Shortened
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=1#post13126
_____ Workbook: 1 26Apr.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1156.6
1156.6
22
11.566
116815
1168.166


3NSEADANIENTEQ
137.15
140.55
134.1
134.65
134.65
25
1.3465
13595
135.9965


4NSEADANIPORTSEQ
273.95
276.95
269.55
270.65
270.65
15083
2.7065
27335
273.3565


5NSEADANIPOWEREQ
32.3
32.35
30.45
30.65
30.65
17388
0.3065
3095
30.9565


6NSEAMARAJABATEQ
555
575
529.25
532.1
570.1
100
5.321
5374
537.421
Worksheet: 1-Sheet1

[DocAElstein]

From last post
Before
_____ Workbook: Alert.txt ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1NSE
14361
6A


2NSE
25
6A


3NSE
15083
6A


4NSE
17388
6A


5NSE
100
6A


6NSE
22
6A


7
Worksheet: Alert


check wheather column H of 1.xls is greater or lower than column D of 1.xls

if column H of 1.xls is greater than column D of 1.xls then match column I of 1.xls with column B of 2.csv & if it matches then put this symbol "<" in column D of 2.csv & copy paste the data of column K of 1.xls in column E of 2.csv

or

if column H of 1.xls is lower than column D of 1.xls then match column I of 1.xls with column B of 2.csv & if it matches then put this symbol ">" in column D of 2.csv & copy paste the data of column K of 1.xls in column E of 2.csv

Run macro ( from here https://www.ozgrid.com/forum/index.php?thread/1227284-copy-and-paste-by-macro/&postID=1233954#post1233954 )

Sub STEP8() ' http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=1#post13126
Dim Wb1 As Workbook, Wb2 As Workbook
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim rg1 As Range, i As Long, c As Range
Set Wb1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Wb2 = Workbooks("Alert.txt") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Alert..csv")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Ws2 = Wb2.Worksheets.Item(1)
Set rg1 = Ws1.Cells(1, 1).CurrentRegion
With rg1
For i = 2 To rg1.Rows.Count
If .Cells(i, 8) > .Cells(i, 4) Then ' if column H of 1.xls is greater than column D of 1.xls
Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv
If Not c Is Nothing Then 'if match found
c.Offset(, 2).Value = "<" ' put this symbol "<" in column D of 2
c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv
End If
Else ' if column H of 1.xls is lower than column D of 1.xls
Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv
If Not c Is Nothing Then 'if match found
c.Offset(, 2).Value = ">" ' then put this symbol ">" in column D of 2.csv
c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv
End If
End If
Next i
End With
End Sub

After - results after running macro above

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

1NSE
14361
6A


2NSE
25
6>
13595A


3NSE
15083
6>
27335A


4NSE
17388
6>
3095A


5NSE
100
6<
5374A


6NSE
22
6>
116815A


7
Worksheet: Alert



1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
macro.xlsm : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Alert.csv : https://app.box.com/s/4ejptbaggn67nc91yz9jhgcefm2qae0r

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13131&viewfull=1#post13131
It is not necessary to have all data to demonstrate the problem!!

....It is difficult in a forum to work with many rows.
Reduce the rows
We need just enough data to test.
Pick your test data carefully.
Just use a few rows. But pick your test data carefully so that it test all scenarios....

....make a small file with also row data that errors.
Explain again and show me what and where the errors are….


_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166


3NSEDABUREQ
499
503.75
494.5
499
499.05
772
4.9905
4941
494.0595


4NSEDISHTVEQ
5.1
5.15
4.75
4.95
4.75
0.0475
475
4.7975


5NSEUBLEQ
921
922.5
863.85
920
880.75
16713
8.8075
88955
889.5575


6NSEUJJIVANEQ
170
173.5
161.6
179.55
164.1
17069
1.641
1657
165.741


7NSEVEDLEQ
76.8
80.25
75.7
77.6
77.95
3063
0.7795
772
77.1705


8NSEVOLTASEQ
500
505
485
508.2
487.15
3718
4.8715
49202.15
492.0215


9NSEZEELEQ
150.8
152.85
143
157.55
145.15
3812
1.4515
1466
146.6015


10


11


12
Worksheet: 1-Sheet1 27Apr_2


Before

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

1NSE
25
6A


2NSE
3812
6A


3NSE
15083
6A


4NSE
22
6A


5
Worksheet: Alert.

Run macro, then we have After results:

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

1NSE
25
6A


2NSE
3812
6>
1466A


3NSE
15083
6A


4NSE
22
6>
116815A


5>
475
Worksheet: Alert.



match column I of 1.xls with column B of 2.csv

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
F
G
H
I
J

1Low Prev CloseLTP


2
1151.7
1190.45
1156.6
22
11.566


3
494.5
499
499.05
772
4.9905


4
4.75
4.95
4.75
0.0475


5
863.85
920
880.75
16713
8.8075


6
161.6
179.55
164.1
17069
1.641


_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

3NSE
15083
6


4NSE
22
6


5


6


match column I of 1.xls with column B of 2.csv
column I of 1.xls is Empty
column B of 2.csv is Empty
Empty = Empty = Match



_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
F
G
H
I
J

1Low Prev CloseLTP


2
1151.7
1190.45
1156.6
22
11.566


3
494.5
499
499.05
772
4.9905


4
4.75
4.95
4.75Empty
0.0475


5
863.85
920
880.75
16713
8.8075


6
161.6
179.55
164.1
17069
1.641


_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D

3NSE
15083
6


4NSE
22
6


5Empty


6

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13140&viewfull=1#post13140

Explanation of the problem
The error is caused by bad understanding of Range.Find Method ( https://docs.microsoft.com/de-de/office/vba/api/excel.range.find )

We only need small amount of test data to demonstrate the problem:
Consider the results of this test data

Before:

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166


3NSEADANIENTEQ
137.15
140.55
134.1
140.5
134.65
25
1.3465
13595
135.9965


4NSEADANIPORTSEQ
273.95
276.95
269.55
277.6
270.65
15083
2.7065
27335
273.3565


5
Worksheet: 1-Sheet1 27Apr_2 (2)

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

1NSE
25
6A


2NSE
17388
6A


3NSE
404
6A


4NSE
422
6A


5NSE
10604
6A


6NSE
438
6A


7NSE
10794
6A


8NSE
1250
6A


9NSE
625
6A


10NSE
15083
6A


11NSE
22
6A


12
Worksheet: Alert.


results After
_____ Workbook: AlertTestData.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F

1NSE
25
6A


2NSE
17388
6A


3NSE
404
6A


4NSE
422
6>
116815A


5NSE
10604
6A


6NSE
438
6A


7NSE
10794
6A


8NSE
1250
6>
13595A


9NSE
625
6A


10NSE
15083
6>
27335A


11NSE
22
6A


12
Worksheet: Alert.


Those results come from using this macro here: http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13143&viewfull=1#post13143
Those results arise due to this problem code line
Ws2.Columns(2).Find(.Cells(i, 9))

That code line is only using one argument for Range.Find Method
So VBA must guess the others. It has guessed not what we want. It has guessed similar to this
Ws2.Columns(2).Find(What:=.Cells(i, 9), After:=B1, LookAt:xlpart)

Because of After:=B1 , it starts to look from B2 in
Because of LookAt:xlpart , we will look for what we want anywhere inside a cell, so if we are looking for the number 25 , then all these numbers or even text could be a match
4567256
2500
25
564rghsseeffzz25adksfhaejh
VBA will choose the first match that it finds

For example, for our 25 it started looking from B2 in Worksheet Alert, and the first it found was 1250


For large data, there will be many errors caused by this problem. But the problem and the solution will be the same.
It is easier to demonstrate the problem with small test data.
It is easier to test a solution with small test data.

It is the responsibility of the person finally responsible for the macros in real use to take the time to check for larger amounts of real data. For getting free help in a forum , this will be the responsibility of the persom getting help.


Share ‘1.xls’ : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Share ‘AlertTestData.xlsx’ : https://app.box.com/s/nhdxcq0ulxldebanz1lz49wr1stf1pc4
Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt