Test Video,YouTube, Video making and editing, etc. coupled to excelfox (OBS) [Archive] - Excel, Access, PowerPoint and Word VBA Macro Automation Help

DocAElstein

09-16-2015, 03:25 PM

Thread 2935 https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox

This is post 23426
https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox?p=23426&viewfull=1#post23426 https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox?p=23426&viewfull=1#post23426
https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox#post23426 https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox#post23426

2014

* Fix an issue where hotkeys pressed while stream delay is finishing would cause a crash (R1CH)
* Fix an issue where disconnections would report the wrong error code (R1CH)
* Fix an issue with network initialization (R1CH)
* More error/bug checking/logging (R1CH)
* You no longer have to use the nvidia control panel to make nvidia laptops capture properly, you can now simply select the nvidia adapter in OBS and it will function properly (Jim)
* Fix a bug with using two push to talk hotkeys, make it so that if both buttons are down, only when the second button is released will it deactivate push to talk. (Jim)
* Can now "reset" your mic if necessary in audio settings if for whatever reason the mic audio device needs to be reset, which will cause it to reacquire itself. (Jim)
* Fix mic removal/disconnection flaw, if your mic gets disconnected it's no longer required to restart the stream, it will automatically reacquire when it's plugged in again. (Jim. FINALLY. Why, Jim, did you take so long with this? This was a serious issue. Why am I referring to myself in the third person? ..Why am I talking to myself?)
* Fix mic/device gradual syncing issues, remove "Mic Sync Fix Hack" in advanced because it fixes that problem. This was an issue that mostly happened with mics, the Avermedia Live Gamer Portable, and next-gen consoles (Jim)
* More improvements to QSV (Palana)
* Add NVEnc encoder (Written by BtbN. NOTE: requires nvidia key on non-quadro nvidia video devices)
* Because the above required more room, the "Dashboard Link" button has been removed.
* Add separate Start/Stop Recording button to the main window, you can now stop/start recording without stopping the stream. On top of that, reconnecting will no longer stop everything, you will keep recording while reconnecting. Notification also added to the status bar when streaming and/or recording is on/off. (Thanks to the awesome Paibox/Palana duo)
0.60 Beta - 2014-02-02

* Made a workaround for an issue where kona lhi devices wouldn't work properly due to their incomplete directshow filters (Jim)
* Removed the nvidia optimus "workaround" because nvidia optimus drivers seem to be too unstable when handling it and can crash when its used (Jim)
* Make it so the "WTF" log message for system clock only occurs if over a certain threshold (Jim)
* Added a log window that can be opened and viewed while streaming (Palana)
* Fixed a crash that would happen if you press start streaming and stop streaming too quickly (Palana)
* Added a few new options for QSV, and made a few minor improvements (Palana)
* Disable "keep recording" checkbox if file output is disabled (Palana)
* Add start/stop recording hotkeys (Palana)
* If set to both stream and record, enable recording button when not streaming (Palana)
* Moved "Open Log Folder" to help menu (Palana)
* Added new "Log Files" submenu to the help menu. In this menu, you can now run the analyzer on your log files, upload log files to github gists to make it easier for devs to see, or view them yourself without having to go to the folder. (Palana)
* Refactored bitmap handling and allow animated gifs in the slideshow (HomeWorld)
0.610 Beta - 2014-02-16

* I didn't properly recompile QSV stuff, which caused it to crash. Fixed that. (Jim)
* Fixed a bug with elgatos where they wouldn't work (Jim)
* Fixed issue with analyzer (R1CH)
0.611 Beta - 2014-02-16

* Fixed a bug with FLV files (paibox)
0.612 Beta - 2014-02-18

* Add -profile [profile name] command line option to start up with a specific profile (Jim)
* Add a small visual indicator for global sources in the sources list box (HomeWorld)
* Added an "aspect ratio" display to video settings (Palana)
* Moved "Use input device for desktop audio" to advanced settings (Palana) (certain individuals suddenly shed tears of joy)
* Fix right-to-left language support so it displays in the proper order (Palana/Jim/AlderaaN)
* Fix a crash with higher bitrates on nvenc (BtbN and R1CH)
* Make a few adjustments to QuickSync encoder (Palana)
* Move Nvenc/Quicksync encoder selections to encoder settings (Palana)
* Fix start/stop streaming hotkeys when used with the same key (Palana)
* Add support for controller hotkeys (BtbN)
0.613 Beta - 2014-03-07

* Remove 'use input devices for desktop audio' and make it so it can only be used via ini file. If you need to use it, then enable it in your profile ini file in %appdata%\obs\profiles, under [Audio], InputDevicesForDesktopSound=1 -- we are not going to provide an option in the UI for this because people kept enabling it without know what they were doing.
* Reduce the minimum allowable reconnect timeout to 0 (Jim)
* Fix an issue with game capture where the mouse cursor wouldn't always show up after updating its settings (Homeworld)
* Renamed 'audio time offset' to 'audio sync offset' so users actually know specifically what it is (Jim)
* Added some more important logging info, especially things like logging what game capture is trying to hook to, and logging audio sync offsets (Jim)
* Add a fast experimental windows 7 monitor capture method in game capture (homeworld)
* Fix mono audio (Jim)
* Fix 'defaults' button behavior in advanced (paibox)
* Fix audio mute threshold (R1CH)
* Fix invalid log generation (Palana)
* Fix a lot of bugs (Palana & R1CH)
* Implement an 'optimize' button in publish settings (Palana)
* Add optional 'safe' game capture hooks for anti-cheat compatibility (Jim)
* Use safer hooks so that using other hook programs doesn't cause the target game crash with game capture (vulture)
0.620 Beta - 2014-04-23

* Made it so you cannot assign left/right mouse buttons as hotkeys (listen, I know that some people are going to disagree with this, but it's causing some serious problems for new users. They accidentally click the mouse in the box and then don't realize they set a hotkey to their mouse button, and then say "why is this action occuring every time I click my mouse?" ..Please, find a different key/button to use or put it in the ini file manually)
* Clarified some text about the anti-cheat option (basically, don't use it unless the game has anti-cheat protection because otherwise it can flag a false-positive as well, which is INCREDIBLY annoying)
* Fixed a potential anti-virus false-positive with game capture that was happening with 0.62b
0.621 Beta - 2014-04-23

* Fixed an issue with game capture that caused it to stop working for many people
0.622 Beta - 2014-04-25

* Fix game capture performance issues with the latest windows 8.1 update that was causing many games to lag (jim)
* Save the hidden unmuted volume values if exiting the program while volume was muted (jim)
* Add 'set base resolution' back to window capture by popular request (jim)
* Fix potential audio/video sync issues that would happen with hardware encoders (jim)
* Changed to new volume icons (homeworld)
* Make a few minor improvements to quicksync (palana)
* Fix NVenc with the latest nvidia drivers and beta drivers (btbn)
* Warn users if they installed plugins of the wrong architecture (r1ch)
* Show an error if game capture is blocked by an outside source (r1ch)
0.623 Beta - 2014-05-21

* Made a hotfix for streams not loading properly due to a commit that managed to pass initial testing (the quicksync/nvenc sync fix)
0.624 Beta - 2014-05-21

* Update localization files for different languages (slipped by me last time)
* Updated server lists
* Again attempt to fix the bug where QSV/nvenc could sometimes cause streaming to sort of bug out (jim)
* Update nvenc (btbn)
* Update x264 version (btbn)
* Show warning if comodo antivirus is blocking the network connection for whatever reason (r1ch)
* Fix game capture performance issue for D3D9 games on latest windows 8.1 versions (jim)
0.625 Beta - 2014-06-16

* Use application compatibility manifest to prevent OBS from running on unsupported revisions of windows (R1CH)
* Preserve game capture target even if it isn't running (R1CH)
* Move "show log window" to help menu (jack0r)
* Remove help file, replace with online help which is more up-to-date (jack0r)
* Check for XInput support in the installer (R1CH)
* Remember 1:1 preview state on restart (Jim)
* Made it so game capture hotkey will remember as well as save the window it was last assigned to capture to, and always attempt to re-hook it again (Jim)
* Disable QSV encoder settings if QSV isn't selected as encoder (Palana)
* Remove justin.tv references (R1CH)
* Improve game capture hooking (R1CH)
* Make a number of improvements to quicksync encoder (Palana)
* Update NVenc to latest NVenc API and make a number of improvements (BtbN)
* Update x264 to fix a crash that was occurring due to its version (R1CH)
* Fix issues with BF4 and borderless windowed mode (Jim)
* Fix some freezes that could happen when stopping stream (R1CH)
* Fix keyboard tab order of all controls in the properties/settings windows (jack0r)
* Fix other various random minor bugs and potential issues (R1CH)
* Fix bug where the log menu wouldn't display things correctly (Palana)
* Fix issues with some unicode characters not displaying correctly (Jim)
* Fix a crash if removing global sources with no scenes (R1CH)
* Fix a crash in audio settings if no devices are present (R1CH)
* Fix potential github gist API issue (R1CH)
* Fix issue where game capture would stop capturing certain games such as league of legends after the game goes back to lobby (Jim)
* Add a 'Copy To' option in scenes to allow you to copy scenes between scene collections (Glought)
* Add 'import' button to the global sources dialog to allow importing of global sources from other scene files (Glought)
* Add scene collections feature (ability to change between different sets of scenes, accessible via the 'scene collection' menu) (Glought)
* Add option in uninstaller to remove all saved settings and plugins (R1CH)
* Add a dedicated hotkey panel in settings (Palana)
* Add a drop-down to the recording button which has an option to use standard recording, replay buffer, or both at the same time (Palana)
* Add a replay buffer feature that allows you to save video files of the last configured number of seconds (Palana)
* Add DirectX 8 and DirectDraw capture to game capture (bl00drav3n)
0.630 Beta - 2014-09-07

* Fix a bug where sources that have inverted textures would not display
0.631 Beta - 2014-09-07

* Fix a freeze issue with quicksync
* Restore "Push to talk" checkbox
* Fix a bug with "Copy To" in the scenes context menu in 64bit
0.632 Beta - 2014-09-10

* Add "Show replays" menu to the file menu (palana)
* Update service list (r1ch)
* Fix "Show recordings" in the file menu (palana)
* Fix a bug where second push-to-talk hotkey wouldn't stay assigned (palana)
0.633 Beta - 2014-09-13

* Update services
* Fix bugs with recording file names
* Add support for elgato resolution changing (1920x1080, 1280x720, 640x480, 480x360) (Jim)
0.634 Beta - 2014-09-15

* Fix a service that was unintentionally removed (r1ch)
* Fix issues with elgato (Jim didn't test with the elgato 1.x.x software)
0.635 Beta - 2014-09-16

* If an elgato device is in use and 'custom resolution' is not set, it will default to the closest resolution to the OBS base resolution
* Disable QSV on windows vista, as it's not supported (Palana)
* Make it so that streams can close without freezing up the application. You can't start the stream util the stream until the previous stream has stopped, but it will no longer freeze the main window (Palana)
* Add warnings when using invalid file paths with replay buffer or recording (Palana)
* Fix replay buffering being marked as disabled when start recording fails (Palana)
* Fix a crash with elgatos when using 'output to desktop' for audio (FBirth)
0.636 Beta - 2014-10-02

* Fixed a crash on start streaming that could happen (for example if stream delay was enabled) (Palana)
0.637 Beta - 2014-10-04

* Fixed D3D9 game capture performance issues on the latest update of Windows 8.1 (Jim)
* Removed Chicago from twitch ingest list (CommanderRoot)
* Hopefully fixed an MP4 corruption bug that was occurring under certain circumstances (Palana)
* Fixed monitor capture not updating coordinates when switching monitor (Palana)
* Optimized scene transition fade (HomeWorld)
* Fixed the Advanced -> Custom quick sync encoder settings not enabling buttons (Palana)
* Added a "Enable alpha blending" option to game capture that allows the alpha of the capture to be utilized (Mattias Gustavsson)
0.638 Beta - 2014-11-11

DocAElstein

09-16-2015, 03:25 PM

2015

* Fixed a button label issue when starting/stopping streaming
* Added a check to make sure if adapter still exists; if not, use default
* Added option to advanced settings to allow full color range encoding (partial by default for compatibility purposes)
* Added option to allow the ability to set the YUV color space and color range for video devices
* Added support for IPv6
* Fixed bug where warnings for CBR/keyint/etc wouldn't display for certain services (like hitbox)
* Fixed NVenc CBR to actually be constant bitrate
0.64 Beta - 2015-01-23

* Fixed a few issues with Elgato devices and made sure that buffering is always enabled for them as the default
* Fixed a bug with animated gif handling
* Fixed a bug with with game capture potentially causing crashes in 64bit games
* Updated x264 to the latest revision
* Added Opacity option to slide show source
* Added the scene switcher plugin as an OBS default plugin
0.65 Beta - 2015-03-06

* Updated server list
* Fixed debug files
* Minor Bug fixes
0.651 Beta - 2015-03-25

* Fixed a potential crash with gif files
* Fixed a bug where transitions set to under 3 seconds would get stuck
* Added ability to add custom services
* Added ability to add folders to image slideshow source rather than individual files
0.652 Beta - 2015-07-10

* Fixed a bug where adding folders to the image slideshow wouldn't work properly
0.653 Beta - 2015-07-21

* Fixed an issue with log files not reporting the correct windows version
* Fixed windows 10 slowdown capturing DirectX 9 games with game capture
0.654 Beta - 2015-08-02

* Fixed a windows 10 slowdown capturing DirectX 9 games with game capture (due to a recent windows update that invalidated the last patch)
0.655 Beta - 2015-08-09

* Fix outdated DirectX installer link
* Fix FLV format bug that affected some video file players/demuxers
* Add support for more quicksync CPUs
* Save scenes/sources when windows itself is shutting down the program
* Don't deselect when ctrl-clicking empty space
* Don't snap crop when resizing a source
0.656 Beta - 2015-10-02

* Updated game capture for latest windows 10 update
* Fixed a bug where certain devices (particularly elgato devices) could cause a crash when they change resolution or when starting up
0.657 Beta - 2015-11-24

DocAElstein

09-16-2015, 03:25 PM

DocAElstein

09-16-2015, 03:25 PM

Contents

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
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=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (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=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=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
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=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg)
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/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

DocAElstein

09-16-2015, 03:25 PM

DocAElstein

09-16-2015, 03:25 PM

OBS Classic, Open Broadcaster Software (original stuff).
2012

* Added experimental 7.1 speaker support. I don't know if my coefficients are correct as I don't know the exact math behind downmixing, so it may sound a bit off. At the very least it won't crash with that setting anymore, hopefully. If anyone can explain the correct math or help me out with properly downmixing, it would be greatly appreciated.
* Fixed some other crashes related to x264
* Fixed some mic and audio related crashes, hopefully your microphones should work now
* Fixed some crashes when adding sources, especially the desktop capture source.
* Fixed a major framerate and smoothness bug with the video. Video should now be operating smoothly and at the intended framerates (that your system can support at least). Stayed up to like 5 in the morning trying to pinpoint that one
0.32a - 2012-9-01

* Please email me if there are any issues with your bitrates or unexpected lag for your upload bandwidth -- not a verified issue, but if there are, please let me know
* Please email me (obs.jim@gmail.com) if there are any bugs, if or if you would like to suggest new features
* Added Window and Region capture, renamed source to "Software Capture"
* Fixed bug where most bitmaps were not displaying
0.33a - 2012-9-06

* Updated DirectShow video device plugin so you can type in a custom resolution.
* Changed some internal encoder setting so it gets a bit better quality as well as better compression ratio
* Known issue: Window capture captures windows above when aero is disabled. Not sure if anything I can do about it.
* Window capture will now simply freeze to the last frame if minimized rather than show a horrible black rectangle
* Added a display in the window that shows you your bandwidth usage when streaming, and shows whether your bandwidth demands are too high with a color indicator (green is good, red is bad)
* Greatly improved network code, bandwidth usage will now adjust depending on your throughput
* Fixed 7.1 bug that caused it to sound like there was static (7.1 code is still experimental though)
0.34a - 2012-9-08

* Switched to D3D10.1 to improve compatibility with many GPUs
* Fixed directshow bug where certain resolutions could crash (thanks to R1CH for pointing out the code)
* Added some more network code that greatly improves bandwidth usage. You should now be able to get much better bitrates. (thanks to frostshocker, modnite, kendobear, and d2ultima for helping out with this one)
0.35a - 2012-9-10

* Added a "disconnected by server" message when disconnected by the server
* Fixed bug that caused own3d settings to be saved as twitch
* Fixed more directshow bugs
0.36a - 2012-9-12

* Added a video/audio sync fix for certain CPUs/motherboards
* Refined network code a bit more
* Added tooltips to some controls to give them more description when the mouse is hovering over them
* Added global hotkeys to the API and added scene hotkeys. Set scene hotkeys by right clicking the scene and going to "Set Hotkey"
0.37a - 2012-9-16

* More DirectShow bugfixes (R1CH)
* Fixed a major bug with mic audio where certain mics would have a static-like sound and just sound horrible in general.
* Past 20 log are now saved. Now stored in the %AppData%\OBS\logs directory.
* Changed the way settings are saved. All settings are now saved inside the windows %appdata%\OBS directory. (i.e. C:\Users\[windows user name]\AppData\Roaming\OBS). Please use the migrateSettings.bat provided if upgrading from a previous version.
* Added a popup menu when you right click the render window, allowing you to disable it or show the current capture FPS.
* Added setting profiles, so that you can use multiple channels or specific settings for specific situations.
0.38a - 2012-9-20

* Finally started using an installer
* Fixed some bugs in downscaling code, downscaling should now look more accurate
* Fixed bugs in the way data was sent over the network, also should make colors look more accurate (major thanks to R1CH here for helping figure out the issue, wouldn't have found it or known about it without him)
* Added options for hotkeys for things like muting and push-to-talk
* Added advanced settings section for custom encoder settings and such
* Added automatic reconnecting feature
* Added options to output stream to MP4 or FLV files
0.40a - 2012-9-27

* Added "Fit to screen" option for sources
* Made it so default names appear when creating source/scenes
* Added Slide Show image source
* Fixed Hotkey issues, added "disconnect" hotkey
* Fixed AverMedia card problems
0.41a - 2012-10-2

* Updated russian translation
* Fixed an issue where older cards would output garbage to the stream in 0.41a
0.411a - 2012-10-3

* Fixed FLV file output (hopefully)
* Fixed an issue that would cause you not to connect to some services, such as livestream/ustream.
* Improved compatibility with more video cards and computers, and hopefully with more laptops as well.
* Fixed bugs related to adding/removing sources, as well as bugs relating to adding/removing global sources
* Fixed a bug that caused garbled output on some video cards
* Fixed various bugs in the directshow plugin, improved device support for more devices
* Added an option to boost microphone volume in the audio section
* Also improved the "Sync Fix" option to be much smoother for any who still need to use it, it is now a very viable option as long as you keep your max FPS near or below your capture FPS
* Fixed bugs related to audio/video syncing
* Improved network code again
* Added a menubar/status bar, status bar now displays frames dropped and capture FPS as well.
* Added a "Dashboard" button as per the request of some users
* Added a "Start Stream" hotkey
0.42a - 2012-10-10

* Made it so edit controls with an up-down control are no longer read-only
* Changed the "Mic boost" setting to a multiple, and changed it from 100%-400% to a 1-20 multiple.
* (Hopefully) Fixed a bug with window capture that could cause it to capture unrelated windows in rare circumstances
* Fixed a bug that would cause the app to freeze sometimes when stopping the stream or exiting
* Fixed a bug with the "Sync Fix" that would cause it to occasionally crash with the "out of range" list error.
0.421a - 2012-10-11

* More network code improvements, and fixed an issue that would cause too many frames to drop once they started dropping
* Fixed annoying bug where status bar would flicker when updating
* Fixed many "out of range!" bugs
* Increased overall stream performance
* Greatly increased performance with devices such as avermedia
* Added blackmagic intensity support
* Added Color Key feature to Capture Device source (for bluescreens and greenscreens)
* Added Text Source
0.43a - 2012-10-28

* Added an advanced feature to let users select the specific output type their device is using while capturing (as requested by a user)
* Fixed a bug that would cause some devices to not show anything
* Changed the way FPS works in the device source plugin
* Fixed a bug with some devices still showing garble
* Fixed a problem where text would get cut off in certain cases
* Fixed bug that would cause text source not to appear on some computers
* Added color key to software capture, as requested by a surprising number of people
* Changed color key to chroma key in the device source -- also made it not suck (all hail muf for pointing out specific details)
* Added ability to use Ctrl/Shift/Alt alone as hotkeys
0.432 Alpha - 2012-11-02

* Added improved crash code
* Added feature to allow higher FPS values in advanced
* Added ability to capture layered windows to software capture
* Added opacity to video plugin
* Fixed bugs with text source, fixed the problem with the [!] message
* Added stream uptime display
* Changed the way custom server entry is used, now uses proper FMS URL and channel/key
* Added stream delay feature
* Added animated GIF support for images
* Added first version of game capture plugin (Warning: currently in beta/experimental phase)
0.446 Alpha - 2012-11-22

* Fixed an issue where frames could drop more than intended
* Fixed a bug where custom RTMP URLs ending with a slash could sometimes cause crashes when starting the stream
* Fixed a bug where game capture cursor would sometimes appear garbled or messed up
0.447 Alpha - 2012-11-23

* Fixed bug that prevented twitch video uploading (hopefully)
* Fixed some crashes with game capture
* Fixed a memory leak with game capture
0.448 Alpha - 2012-11-25

* Fixed japanese translation (thanks to nico_lab)
* Made the app save it's position
* Added text outline feature (courtesy of homeworld)
* Added finnish translation
* Fixed Windows 8 specific problem where the FPS would be a few FPS lower than was set to
* Fixed more crashes with experimental game capture
* Fixed network throughput issue on some network connections (was causing some users to drop frames way below their upload rate)
0.450 Alpha - 2012-12-05

* Fixed a bug that caused to outright crash on windows 7 and lower (sorry, I had upgraded to windows 8)
0.451 Alpha - 2012-12-05

* Fixed a crash that happened for new users
0.452 Alpha - 2012-12-05

* Other random bug fixes and tweaks
* Fixed many cases where game capture couldn't acquire a game
* Added "Bind to network" interface
* Added audio level indicators (an awesome contribution by Bill Hamilton)
* Hopefully fixed a bug that would cause transcoders for partnered streams to not show the full transcoding range, and hopefully the twitch thumbnails as well
* Fixed a problem where multiple devices of the same name could not be used (couldn't find a tester for this so may be slightly untested)
* Fixed pretty much all sync-related issues, mic or desktop (hopefully)
0.455 Alpha - 2012-12-13

* Fixed an issue where some mics could randomly stop playing to the stream
0.456 Alpha - 2012-12-13

* Fixed audio level indicators to be instant response
* Fixed a crash in video capture
* Fixed a problem where sound came out like static
* Fixed another issue where some mics wouldn't play
0.457 Alpha - 2012-12-13

* Added experimental windows 8 monitor capture. (Use software capture->monitor capture). Currently cursor does not display with it. Cannot adjust region yet. Very very fast capture.
* Fixed rather critical bug introduced with 0.455-0.457 that could cause stream to "decay" after 30-120+ minutes on some computers
0.458 Alpha - 2012-12-15

* Fixed a bug that would cause sound levels to be really low when not using maximum sound volume for either mic or desktop.
0.459 Alpha - 2012-12-15

* Fixed a bug when deleting global sources
* Fixed a bug when deleting multiple selected sources
* Removed one pesky minor memory leak
* Fixed a crash that could sometimes happen at CalculateVolumeLevels
0.460 Alpha - 2012-12-16

* Added a push to talk delay for when the key is released due to high request
* Made it so that changing profiles updates all profile hotkeys and the dashboard link and all that
* Added mouse cursor to win 8 capture, fixed some bugs with multi-monitor setups
* Made game capture sizable/positionable, and added an "ignore aspect" option because it was so frequently requested
* Fixed a bug where push to talk and muting was delayed. Should now be instant
0.461 Alpha - 2012-12-16

DocAElstein

09-16-2015, 03:25 PM

Thread 2935 was original first post https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox

This is post 23584
https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox?p=23426&viewfull=1#post23426 https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox?p=23584viewfull=1#post23584
https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox#post23426 https://www.excelfox.com/forum/showthread.php/2935-Testing-Videos-YouTube-Video-making-and-editing-etc-coupled-to-excelfox#post23584

2013 January - May

* Fixed some more minor memory leaks
* Fixed a bug with MP4 audio/video sync
* Fixed a bug with game capture not being properly movable
* Fixed a bug with stream keys/play paths failing
* Fixed more issues related to mic syncing
* Fixed a bug with frequent disconnects
* Made it so that windows won't go into an idle state while streaming
* Added improved volume meters courtesy of Bill Hamilton once again
* Added a new and improved installer courtesy of R1CH
* Added an auto-updater courtesy of R1CH
* Added options to adjust microphone and capture card audio timing
* Finally implemented capture card audio output options
0.465 Alpha - 2013-01-02

* Added goodgame.ru to services.xconfig after mistakenly taking it out at some point
* Fixed mic crash
0.466 Alpha - 2013-01-04

* Added support for Elgato capture cards (many thanks to the Elgato team)
* Added a "profiles" menu to quickly switch between multiple profiles
* Added the command line option -multi to allow multiple instances of the app to be opened at the same time
* Made numerous changes to the text output, you may need to adjust your text settings or reset the size (coded by HomeWorld)
* Changed the "sub-region" selection window so that it's partly transparent (fixed by HomeWorld)
* Removed the "timestamp" crash and improved compatibility with VAC and many headphones which were having problems
* Added an option to select the desktop sound device (coded by Resonant)
* Added an option for CFR (constant framerate encoding) in advanced for more compatibility with editing programs
* Fixed some more issues with MP4s and improved their compatibility with many editing programs
* Inverted the source list so that sources that are top most are actually at the top and so forth
* Added checkboxes to the sources box so that sources can be disabled while streaming (coded by Bill Hamilton)
* Added an option in advanced to adjust all audio time
* Added an option "Force audio to sync to video time" in advanced settings (just in case there are still any lingering sync issues for anyone)
* Fixed some more issues with mic/audio timing and sync
* Added "low latency mode" which reduces ping issues with multiplayer games and other network applications (coded by r1ch)
0.47 Alpha - 2013-02-04

* Made is so that the scene is periodically saved, can also be saved in the file menu, loading/saving/exporting/importing will probably be added in the future
* Fixed a bug where preset=[preset] or tune=[tune] in custom x264 settings would cause x264 to fail to initialize
* Fixed a few bugs with text
* Fixed a bug where sources would still be active even when disabled
* Fixed a bug with the UYV chroma key shader
* Fixed a bug where the checkboxes in the sources box wouldn't always show up in windows 7 classic theme
* Fixed a bug with new sources being created at the back of the scene instead of the front
* Fixed a crash that could happen while mp4s are building
* Updated x264 dll to the "stable" x264 branch build rather than the latest development master branch, which should hopefully fix the crashes people have been having with it
* Made it so game capture 64bit works with 32bit games and vise versa without having to switch between versions
* Added gamma options to software capture and game capture
0.471 Beta - 2013-02-17

* Added Hashd.tv to the services list
* Fixed a bug with how game capture inject helper was compiled that could cause it to fail under certain circumstances
0.472 Beta - 2013-02-18

* Numerous other bug fixes and crash fixes
* Added a Microphone Noise Gate plugin [Lucas Murray]
* Changed the settings menu and plugin API to allow plugins to have their settings in the main settings window [Lucas Murray]
* Added right click option to the preview area to switch between 1:1 view or stretch to fit [Lucas Murray]
* Added right click option to the preview area to hide the OBS controls [Lucas Murray]
* Added right click option to the preview area to fullscreen it [Lucas Murray]
* Added a message when not previewing or streaming to indicate such [Lucas Murray]
* Updated a number of translations
* Updated x264 to the latest branch
* Updated the help file
* Made a workaround for those buggy homebrew PSeye drivers (I think. ugh.)
* Fixed a number of bugs in the audio subsystem, devices with audio playback issues should now play correctly (Ex. Blackmagic and certain microphones)
* Fixed image sources rendering at 99% opacity when opacity is set to 100
* Fixed a few minor issues with MP4/FLV files
* Fixed issue with CBR transmission in general, should now properly insert the correct SEI data
* Fixed issues with CBR not padding data correctly to make it fully constant bitrate
* Fixed a bug causing the first keyframe not being properly sent with the transmission
* Fixed a couple memory leaks
* Fixed some minor issues with 64-bit Game Capture
* Fixed a bug in advanced with global audio offset
* Fixed a crash related to cursors changing sizes (moving users on teamspeak and mumble. ugh.)
* Fixed a bug where some cursors wouldn't properly display in Game Capture and Windows 8 Software Capture
* Fixed some anti-viruses flagging game capture as a false positive (due to the nature of game capture having to intercept frames directly in the game itself this is always a possibility)
* Added a "use buffering" option to devices. Allows you to specify a buffer duration to delay the device, and will also sync the audio/video. This is a fix especially for Elgato devices and webcams and such.
* Added a hotkey to Game Capture the currently focused window
* Added the ability to delay video capture device sources
* Added a -portable launch option to save settings within the OBS folder instead of in the normal directory. Alternatively, you can also use an empty file named "obs_portable_mode" in the directory to automatically enable it.
* Added the bitrate estimation in the bottom right corner to previewing
* Added a selection of Audio Input Device to the Video Capture Device source. Used for capture cards or forcing a microphone to sync to a video device.
* Added point filtering to Window, Monitor and Video Capture
* Added an opacity setting to the outline option in Text source
* Added a "Defaults" button to the Advanced settings section
* Added a "Video Adapter" dropdown to the video settings to select the video card for OBS
* Added an optimization to the DirectX pipeline
* Added some lower audio bitrate options
* Added "Desktop audio boost" to audio settings, allows boosting of desktop audio sound (in multiples)
* Added an audio filter API for plugins
* Added more downscale options, such as 1.25, 1.75, 2.5, 2.75
* Added Bicubic and Lanczos downscale filters for sharper and more detailed downscaling
* Added an option to use microphone QPC timestamps in advanced settings
* Added an option to adjust the scene buffering time in advanced settings
* Added a compatibility mode option to software capture (renders to RAM first to prevent issues with multiple GPUs)
* Added the ability to duplicate a scene [partouf]
* Added an optional tray notification icon (Configured via general settings) [foxx1338]
* Added right-click options to sources to move to each of the four edges [ThoNohT]
* Added right-click options to sources to center just horizontally or vertically [ThoNohT]
* Added stream start and stop time to log files [ThoNohT]
* Added color key functionality to Image sources [paibox]
* Added a second Push-To-Talk hotkey to audio settings [paibox]
* Added crossbar options to video capture device sources [paibox]
* Made MP4 audio fully seamless as well to reduce editing issues
* Seamless audio data should now fix sync bugs with twitch transcoders for their youtube uploading and the partnered transcoder resolution drop-down
* Fixed audio data so that all audio segments are seamless
* Changed frame timing to a much higher precision technique, should reduce frame jitter
* Changed sources so they don't reset size when you change settings while previewing or streaming
* Changed the network code a bit to remove nearly all of the delay that was caused by internal buffering
* Changed how the frame drop code works
* Split Software Capture into Window Capture and Monitor Capture for clarity, old software capture sources still work
* Removed most of the compile time for MP4 recordings, was getting really annoying.
* Various optimizations to the application itself
0.50 Beta - 2013-04-22

* Added basic cropping support (Hold Alt and drag the edge of the source while editing a scene)
* Fixed a potential mic bug where mic audio can go out of sync (blasphemous sync issues)
* Fixed a bug with the window capture dialog and sub-region selection numbers resetting
* Fixed an issue where capturing would slow to a crawl in certain rare circumstances and computer configurations
* Fixed a bug where game capture would shut down before it had a chance to start on some machines, resulting in black capture or frozen frame
0.51 Beta - 2013-04-26

* Improved error reporting of network and RTMP errors
* Including microsoft's dbghelp.dll in order to ensure proper crash logs are generated
* Fixed an issue where initial disconnects would trigger the reconnect dialog instead of reporting the issue
* Made CBR default for new users
* Increased frame drop thresholds slightly because lower bitrate connections could often drop more frames than desired
* Fixed bug with games such as natural selection 2 not capturing with game capture properly in windowed mode
* Fixed various other minor bugs with game capture
* Improved game capture logging in %appdata%\obs\pluginData\captureHookLog.txt
* Added timestamps to all log entries
* Fixed an issue where OBS would not have required access for game capture to capture certain games even when run as administrator (war thunder, many MMOs)
* Fixed another potential crash hazard that I can't actually remember
* Fixed a crash in directshow
* Made some minor improvements to gif files
* Made is so that unchcked sources are internally destroyed when disabled instead of always active
* Improved optimization for any code that can make use of SSE2
0.520 Beta - 2013-05-07

* Fixed a game capture crash
0.521 Beta - 2013-05-07

* Fixed a crash that could occur with some gif files
* Fixed another game capture crash with certain games (such as guild wars 2)
0.522 Beta - 2013-05-08

DocAElstein

09-16-2015, 03:25 PM

2013 July - December

* Someone clone us a few more Palanas, then clone his clones. What's the worst that could happen?
* Prioritize picking FPS rather than resolution for capture devices (primarily for webcams)
* Add option to disable encoding while previewing
* Add additional warnings if trying to use Aero monitor capture on windows 7 and below, allow disabling of Aero at runtime
* Cropping improvements
* Fixed possible crash / corruption when loading multiple GIFs on a scene
* Fixed crash when using network paths for text sources
* Dynamic bitrate changing support
* Updated to latest libx264 build (which now includes OpenCL acceleration options)
* Fixed multiple libx264 crashes (all thanks to R1CH and the x264 devs)
* Per-scene volume support (made by HomeWorld)
* Fixed a stuttering bug that could happen on some systems with game capture
* Fixed a few bugs with OpenGL capturing
* Added game capture support for windows 8.1 preview
* Greatly improved 64bit DirectX 9 game capturing
* Greatly improved OpenGL capturing performance with game capture
* Several methods of deinterlacing support for capture devices (by Palana)
* QuickSync encoding support (by Palana)
0.54 Beta - 2013-07-10

* Fixed a crash with libx264 by switching to linux cross-compiled versions compiled with mingw
0.541 Beta - 2013-07-10

* Added QSV profile for platforms with non-functional D3D11 API version 1.6 support and broken acceleration on API version 1.4 (palana)
* Fixed a crash with retro deinterlacing on I420 and UV12 output from devices (palana)
* Made the "Incompatible hook modules detected" error disableable (r1ch)
* Fixed a few more x264-related crashes (r1ch/x264 devs)
* (Hopefully) Fixed a bug with the stream delay option where if you saved to file while streaming it would cause the network to inadvertently disconnect prior to finishing the rest of delay (Jim)
* Fixed various cropping bugs (r1ch)
* Made it so edit mode is not disabled when going fullscreen (ThoNohT)
* Added more context menu options when right-clicking the preview window (ThoNohT)
* Fixed a bug when using game capture with OpenGL games where the game wouldn't capture on certain systems after updating to 0.54+ (Jim)
* Fixed a pretty bad memory leak when using game capture with OpenGL games that would affect the game itself (Jim)
0.542 Beta - 2013-07-19

* Renamed "lagged frames" to "late frames" to be more descriptive of what they are
* Fixed opacity not working on directshow sources with certain color formats
* Fixed monitor capture rotation issues on Windows 8
* Added support for per-service setting recommendations (currently active for Twitch)
* Added a keyframe interval option to advanced settings
* Added congestion control - reduce bitrate when congestion is detected (experimental, requires .ini editing)
* Added support for RTMP authentication (requires .ini editing)
* Global sources are muted when they not present on a scene
* Allow negative audio offset for video devices
* Fixed a crash when using certain hotkeys
* Improved detection for TeamSpeak 3 and ASUS GamerOSD incompatible hooks
* Support additional D3D versions for Vista game capture
* Refactored network code to minimize risk of disconnects and improve throughput
* Finish processing and flushing all frames before disconnecting a stream or closing a recording
* Fixed a bug where game capture would pick some games up as a 1x1 solid color block
* Reverted GL code for the time being until the newer code is a bit more stable
* Fixed a rather bad mic sync issue that has been happening in rare circumstances
0.550 Beta - 2013-08-15

* Using a new fixed version of fast GL capture
* Fixed some opengl capture crashes
* Fixed game capture causing games to crash with windows vista
* Made the mic sync hack optional (as an option in advanced settings now)
* Fixed a bug with mic cutting out
* Fixed a false positive with norton
0.551 Beta - 2013-08-16

* Fixed a bug with GL game capture that was causing it to use the slower variant on most computers (thanks to kharay for pointing it out and helping debug it)
* Updated some more translations
0.552 Beta - 2013-08-17

* Added streaming requirements check to youtube service listing
* Increased speed of shader loading (palana)
* Added saving of custom colors when bringing up a color dialog
* Updated translations (Many thanks to Gol-D-Ace and dodgepong for helping with new translations)
* Fixed a timeout crash that could occur when stopping stream (kernelbase.dll breakpoint crash, r1ch)
* Added "scroll mode" to text source (by that crazy text-loving homeworld who never sleeps)
0.553 Beta - 2013-08-30

* Re-enabled auto-updater, was off by mistake (if you downloaded 0.553 please download 0.554 instead)
0.554 Beta - 2013-08-31

* Fixed a crash when adding scene with no scenes and preview running (r1ch)
* Added a hook check for Dolby Axon to prevent crashes when in use (r1ch)
* Changed default scene buffering to 700 milliseconds
* Fixed an issue where a cropped source can be moved around by dragging it from outside of its visible area (homeworld)
* Made some minor adjustments to monitor capture (homeworld)
* Added an "x264 Encoder Profile" feature in advanced to change from "high" to "main" x264 encoder profiles
* Made the 64bit and 32bit update checks independent (r1ch)
* Added/Changed a few more services
* Fixed a potential crash when stopping stream (though this might still happen on occasion)
* Removed logging of shader cache files
* Fixed some more issues with quicksync (palana)
* Added date/time for FLV files (palana)
* Reduced minimum selectable FPS to 1 for people who for whatever reasons want to do more slideshow-esque streams
* Added a "projector" feature that allows you to preview the stream on a separate monitor in full screen while using OBS on a another monitor, can be used by right-clicking the preview window and using the "projector" option from the context menu and selecting the monitor to use. The projector window can be disabled by pressing escape on it, by closing it on the task bar, or by using the "disable" option in the context menu.
* Audio can now be encoded in either 48khz or 44.1khz (by Extrems)
* Constant framerate issues resolved and performance improved when using it
* Moved encoding to a separate thread to avoid issues with keyframe interval timing and made CFR default
0.57 Beta - 2013-09-24

* Made a hotfix for a bug where audio can sometimes the mic could cut out. (Need to be careful with those coefficients)
0.571 Beta - 2013-09-29

* Other minor bugfixes and log changes
* Added an option to show only currently plugged in audio devices in the audio section (jim)
* Updated services list (jim)
* Added a -start command line option to start the stream immediately after loading (jim)
* Fixed some issues wth blackmagic/decklink devices to prevent them from blackscreening (don't use the custom resolution checkbox with these devices) (jim)
* Adjusted frame skip threshold to prevent it from triggering too easily (jim)
* Added an option to manually check for updates (r1ch)
* Fixed some crashes caused by external network DLLs (r1ch)
* Made some improvements and fixes to quicksync encoding (Palana)
0.580 Beta - 2013-10-17

* Hotfixed the bug where you couldn't edit the sources properties that somehow managed to squeeze through to release
0.581 Beta - 2013-10-17

* Fixed "push to talk delay", which wasn't working
* Fixed some minor issues with capturing opengl games (hopefully)
* Fixed an issue with windows 8.1 (which just released) where directx 9 games would capture with poor performance
0.582 Beta - 2013-10-19

* Fixed a minor issue where elgato devices would occasionally not initialize properly and have a black screen
* Hotfixed an issue with sources not resizing properly when reconfigured
0.583 Beta - 2013-10-24

* Fixed a bug with window capture's window selection dialog bugging out if there's a window without a title within it (paibox)
* Fixed an issue with game capturing Direct3D 9 games caused by a new windows 8.1 update
0.584 Beta - 2013-11-15

* Switched to the new CBR filler feature of x264 instead of using X264_NAL_HRD_CBR (r1ch)
* Updated x264 to latest development branch (jim)
* Fixed RTMP authentication bug for 64bit OBS (r1ch)
* Added ability to use input devices for the desktop sound channel (for example, use "What you hear" or "Stereo Mix", or even a mic -jim)
* Some QSV fixes/adjustments (palana)
* Fixed some bugs with the shader cache (r1ch/palana)
* Fixed an issue where CoD: Ghosts wouldn't capture properly with game capture (jim)
0.59 Beta - 2013-12-11

* Fixed some issues with locale files
* Force MP3 audio to use 44.1khz to prevent transmission issues, especially with twitch (jim)
* Made it so window capture won't draw a black box if the window isn't found, instead it won't draw anything (so it'll be transparent when the window isn't found -paibox)
* Added "Use WaveOut Renderer" as an option to device source (paibox)
* Fixed an issue where game capture wouldn't capture "Typing of the Dead" properly (jim)
0.591 Beta - 2013-12-16

* Fixed date/time output for FLV files (palana)
* Added 'main' profile override for quicksync, as well as some other minor quicksync tweaks (palana)
* Fixed a potential freeze issue when shutting down stream (r1ch)
* Fixed a bug with per-scene-volume plugin where muting it via hotkey wouldn't properly save settings (homeworld)
* Fixed a bug where device sources sometimes wouldn't properly mute/unmute properly if used as a global source (paibox)
* Fixed an issue with selection of devices that use the same name in the device source (paibox)
* Fixed an issue with game capture performing poorly for DirectX 9 games under certain revisions of windows 7 (jim)
0.592 Beta - 2013-12-28

DocAElstein

05-29-2016, 08:07 PM

OBS Background History timeline notes

Just general timeline notes to be edited / added to

Vista November 2006

Windows 7 October 2009

OBS initially (Open Broadcaster Software)
OBS Studio (original / OBS Classic) started out as a small project created by Lain Bailey, but quickly grew with the help of many online collaborators working both to improve OBS and to share knowledge about the program. The first version was released in August 2012, In 2013, development started on a rewritten version known as OBS Multiplatform (later renamed OBS Studio) for multi-platform support, a more thorough feature set, and a more powerful API.[17] In 2016, OBS "Classic" OBS Classic (Open Broadcaster Software) lost support and OBS Studio became the primary version https://i.postimg.cc/Y9MFNgtH/OBS-Classic.jpg
https://i.postimg.cc/FfC1NYfW/OBS-Classic.jpg (https://postimg.cc/FfC1NYfW) 5643 5645
https://i.postimg.cc/Y9MFNgtH/OBS-Classic.jpg (https://postimages.org/)

OBS Multiplatform, approx. 2013 - 2016

OBS Multiplatform 0.6.4 Nov 3, 2014

OBS Multiplatform 0.7.3 Jan 15, 2015

OBS Multiplatform 0.8.3 Feb 21, 2015

OBS Multiplatform 0.9.1 Mar 27, 2015

OBS Multiplatform 0.10.1 May 19, 2015
Windows 10 July 2015

OBS Multiplatform 0.11.4 Aug 17, 2015 https://i.postimg.cc/4NKtPxn5/0-11-4-Aug-2015.jpg
630 OBS Multiplatform and OBS Studio Tutorial Intro and Interface Tour_0 11 4 Sep 21, 2015
632 OBS Studio Tutorial Best Recording Settings OBS Multiplatform Guide_Sep 25, 2015 Poxy https://i.postimg.cc/VN3G4VWG/Poxy-Black-2015.jpg
632 OBS Studio Tutorial How to Optimize Your Video Settings in OBS Studio_05 Oct 2015 Poxy
640 OBS Studio Tutorial Set Up Hotkeys and Advanced Settings OBS Multiplatform_Oct 7, 2015 Poxy
670 OBS Studio Tutorial Understanding Scenes and Sources OBS Multiplatform_ Oct 13, 2015 https://i.postimg.cc/nLrFJC7j/Poxy-White-Black-2015.jpg
695 OBS Studio Tutorial Working With Custom Profiles OBS Multiplatform_ Dec 11, 2015 Poxy 0 11 4 64Bit
730 OBS Sound Panel Studio Tutorial Multiple Audio Devices (Microphones and Game Sound) OBS Multiplatform_poxy 02 Oct, 2015 8zl-WPD6RME

OBS Multiplatform 0.12.4 Dec 12, 2015

OBS Studio 0.13.4 Mar 21, 2016

OBS Studio 0.14.2 May 16, 2016

OBS Studio 0.15.4 Aug 8, 2016
In 2016, OBS "Classic" OBS Classic (Open Broadcaster Software) lost support and OBS Studio became the primary version
Oct 13 -14 2016 https://web.archive.org/web/20161013154134/https://obsproject.com/ - https://web.archive.org/web/20161014170128/http://obsproject.com/
https://github-cloud.s3.amazonaws.com/releases/5793110/f7f47022-6ec5-11e6-8b87-1e586fd41f5d.exe?X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=AKIAISTNZFOVBIJMK3TQ%2F20161104%2Fus-east-1%2Fs3%2Faws4_request&X-Amz-Date=20161104T034058Z&X-Amz-Expires=300&X-Amz-Signature=bafb115b4138eea9e0b1383c0c3ab15b59c6a7a9 3162a6727ec27b2b0641990d&X-Amz-SignedHeaders=host&actor_id=0&response-content-disposition=attachment%3B%20filename%3DOBS_0_659b_ With_Browser_Installer.exe&response-content-type=application%2Foctet-stream
https://i.postimg.cc/qRtg4gRK/Get-OBS-Classic-0-659-13-Oct-2016.jpg
https://i.postimg.cc/Zqs0G6TZ/Get-OBS-Classic-0-659-13-Oct-2016.jpg
https://i.postimg.cc/g2Y9353t/Get-OBS-Classic-0-659-13-Oct-2016-Nov-2016-2016.jpg
https://i.postimg.cc/xdCW4zxK/Get-OBS-Classic-0-659-13-Oct-2016-Nov-2016-2016-redirect.jpg
https://i.postimg.cc/wjFC2VVq/OBS-0-659b-With-Browser-Installer-exe-from-Wayback-Machine.jpg
Share ‘OBS_0_659b_With_Browser_Installer_From Wayback Machine.exe’ https://app.box.com/s/i3n4bxhuadp77ziqfyxl54xbeg01mmmm

DocAElstein

06-26-2016, 10:27 PM

Approx. from 2016, until about 2020

In 2016, OBS "Classic" OBS Classic (Open Broadcaster Software) lost support and OBS Studio became the primary version
OBS Multiplatform 0.6.4 Nov 3, 2014

OBS Multiplatform 0.7.3 Jan 15, 2015

OBS Multiplatform 0.8.3 Feb 21, 2015

OBS Multiplatform 0.9.1 Mar 27, 2015

OBS Multiplatform 0.10.1 May 19, 2015
Windows 10 July 2015

OBS Multiplatform 0.11.4 Aug 17, 2015 https://i.postimg.cc/4NKtPxn5/0-11-4-Aug-2015.jpg
630 OBS Multiplatform and OBS Studio Tutorial Intro and Interface Tour_0 11 4 Sep 21, 2015
632 OBS Studio Tutorial Best Recording Settings OBS Multiplatform Guide_Sep 25, 2015 Poxy https://i.postimg.cc/VN3G4VWG/Poxy-Black-2015.jpg
632 OBS Studio Tutorial How to Optimize Your Video Settings in OBS Studio_05 Oct 2015 Poxy
640 OBS Studio Tutorial Set Up Hotkeys and Advanced Settings OBS Multiplatform_Oct 7, 2015 Poxy
670 OBS Studio Tutorial Understanding Scenes and Sources OBS Multiplatform_ Oct 13, 2015 https://i.postimg.cc/nLrFJC7j/Poxy-White-Black-2015.jpg
695 OBS Studio Tutorial Working With Custom Profiles OBS Multiplatform_ Dec 11, 2015 Poxy 0 11 4 64Bit
730 OBS Sound Panel Studio Tutorial Multiple Audio Devices (Microphones and Game Sound) OBS Multiplatform_poxy 02 Oct, 2015 8zl-WPD6RME

OBS Multiplatform 0.12.4 Dec 12, 2015

OBS Studio 0.13.4 Mar 21, 2016

OBS Studio 0.14.2 May 16, 2016

OBS Studio 0.15.4 Aug 8, 2016

OBS Studio 0.16.6 Nov 20, 2016

OBS Studio 17.0.2 Jan 19, 2017 OBS-Studio-17.0.2-Full.zip https://drive.google.com/file/d/1T-eefdP3IyH0OCELFEBhkyCLj6UOPLsg/view?usp=drive_web
https://drive.google.com/file/d/1T-eefdP3IyH0OCELFEBhkyCLj6UOPLsg/view?usp=drive_web

11. April 2017 end Vista

https://obsproject.com/forum/threads/obs-windows-7.159078/ Guys anyone who uses windows 7 should download OBS Studio 18.0.1 Its the best its in the official obs studio github site, Sep 1, 2022
OBS Studio 18.0.2 May 2, 2017

OBS Studio 19.0.3 Jun 22, 2017 Added an auto-configuration wizard to the tools menu and on first-time use

570 OBS Studio 20 0 Update Video Transitions, NEW THEME, Modular Interface Sick update walkthrough_Ni69p2j8rhs_11 Aug, 2017 Poxy
639 OBS Studio 129 - Take ULTIMATE CONTROL with Hotkeys OBS Hotkeys Guide - Hotkeys Tutorial_ Nov 19, 2017 Poxy 20 0 1
642 OBS Studio 142 - How to get the BEST Possible Settings for Streaming and Recording (OBS Guide)_Dec 18, 2017 Poxy 20 0 1
701 OBS Studio 102 - User Interface Tour and Walkthrough It can be customized OBS Beginner s Guide_Nov 2, 2017 Poxy 20 0 1 64Bit
https://i.postimg.cc/3w8YY94x/Downloads-Original-20-01.jpg
https://i.postimg.cc/m27PrXDY/Downloads-Original-20-01.jpg
703 OBS Studio 103 - Easy Setup with the AUTO CONFIGURATION WIZARD - Beginner's Guide to OBS Studio_20 Nov 2, 2017 Poxy 20-1
During the creation of this course came big 19 update then 20 update
704 OBS Studio 104 - Profiles and Scene Collections - Scene Collections Guide - OBS Beginners Guide_Nov 3, 2017
705 OBS Studio 105 - Scenes and Sources What are Scenes OBS Studio Beginners Guide to Scenes and Sources Virt Green Screen_Nov 3, 2017
706 OBS Studio 118 - Recording Settings Walkthrough and Setup Tutorial (OBS Recording Guide) OBS HELP_ Nov 8, 2017
706 OBS Studio 117 - What File Format Should You Record To MP4 MKV FLV - OBS File Formats Explained_ Nov 8, 2017
707 OBS Studio 119 - WHAT BITRATE DO I USE - Choosing a Bitrate for Streaming and Recording OBS Guide_Nov 9, 2017
710 OBS Studio 110 - MIXER MASTER How to use OBS Mixer for Multiple Audio Tracks and Balanced Audio_Poxy 05 Nov2017 nd739DyqSV4 20 0 1
711 OBS Studio 111 - Audio Monitoring Guide - How to hear your capture card on PC in OBS (TUTORIAL)_05 Nov 2017
712 OBS Studio 112 - How to Extract Multiple Audio Tracks from OBS Audacity -Audio Tracks not Showing_Poxy05.11.2017_2zvPKiMbcE0
714 OBS Studio 114 - Audio Filter Walkthrough Add effects and quality boosts to your audio TUTORIAL Poxy 7 Nov.2017_nCCRBGWo6ew
OBS Studio 20.1.3 Nov 17, 2017

OBS Studio 21.1.2 May 13, 2018

OBS Studio 22.0.2 Aug 31, 2018
https://softfamous.com/obs-studio/ …… runs on 10 8 7 Vista XP 22.0.03
OBS-Studio-22.0.2-Full-Installer-x86.exe 32bit
OBS-Studio-22.0.2-Full-Installer-x64 64bit.exe

595 How to Record your Computer Screen & Webcam_Mar 4, 2019 Kev 23 0
770 OBS Studio Ultimate Green Screen Guide (OBS Studio Tutorial for Chroma Key Effects Settings and Gear)_AWall Mar 25, 2019 23 02 64Bit
OBS Studio 23.2.1 Jun 15, 2019

The current OBS version 24.0.3 should work with Windows 7
632 Best OBS Recording Settings_Jan 15, 2020 Kev 24 03 64Bit
14. Januar 2020 end Windows 7
594 How to Record Screen on PC for FREE using OBS_Mar 30, 2020 kev 25 0 1
OBS Studio 24.0.6 Apr 14, 2020

618 OBS Studio Komplettkurs 2021 01 Grundlagen (Tutorial)_May 20, 2020 25 0 8 April 26
721 OBS Studio Ultimate Microphone Guide (OBS Studio Tutorial for Mics, Filters and Audio Settings)_Apr 6, 2020 AWAL 25 01 64Bit
702 OBS Studio How to Sync Audio and Video (OBS Studio Tutorial for Sync Offset)_ Oct 26, 2020 AWAL_inKl1YPeAAs_25 0 4
740 OBS Studio Ultimate Microphone Guide (OBS Studio Tutorial for Mics, Filters and Audio Settings)_Apr 6, 2020 AWAL gNUwAwrNiV0 25 0 1
OBS Studio 25.0.8 Apr 27, 2020

DocAElstein

10-23-2016, 02:19 PM

From about version 20 up 2022

OBS Studio 20.1.3 Nov 17, 2017

OBS Studio 21.1.2 May 13, 2018

OBS Studio 22.0.2 Aug 31, 2018
https://softfamous.com/obs-studio/ …… runs on 10 8 7 Vista XP 22.0.03
OBS-Studio-22.0.2-Full-Installer-x86.exe 32bit
OBS-Studio-22.0.2-Full-Installer-x64 64bit.exe

595 How to Record your Computer Screen & Webcam_Mar 4, 2019 Kev 23 0
770 OBS Studio Ultimate Green Screen Guide (OBS Studio Tutorial for Chroma Key Effects Settings and Gear)_AWall Mar 25, 2019 23 02 64Bit
OBS Studio 23.2.1 Jun 15, 2019

The current OBS version 24.0.3 should work with Windows 7
632 Best OBS Recording Settings_Jan 15, 2020 Kev 24 03 64Bit
14. Januar 2020 end Windows 7
594 How to Record Screen on PC for FREE using OBS_Mar 30, 2020 kev 25 0 1
OBS Studio 24.0.6 Apr 14, 2020

618 OBS Studio Komplettkurs 2021 01 Grundlagen (Tutorial)_May 20, 2020 25 0 8 April 26
721 OBS Studio Ultimate Microphone Guide (OBS Studio Tutorial for Mics, Filters and Audio Settings)_Apr 6, 2020 AWAL 25 01 64Bit
702 OBS Studio How to Sync Audio and Video (OBS Studio Tutorial for Sync Offset)_ Oct 26, 2020 AWAL_inKl1YPeAAs_25 0 4
740 OBS Studio Ultimate Microphone Guide (OBS Studio Tutorial for Mics, Filters and Audio Settings)_Apr 6, 2020 AWAL gNUwAwrNiV0 25 0 1
OBS Studio 25.0.8 Apr 27, 2020

https://www.youtube.com/watch?v=oVb1RfcSHLM 16.10.2020 OBS Studio 26.0.2 on Windows Vista with extended kernel Officially only Windows 8.1 or 10! In my experience with 2000 and Vista extended kernel is i usually i have a better change of the program working if it's the portable version.
672 OBS Studio Beginners Guide to Scenes and Sources_Oct 14, 2022
600 OBS Studio How to Download & Install on Windows, Mac and Linux (OBS Studio Tutorial)_26 Dec 7, 2020 AWAL 26 0 2
650 OBS Studio How to Record in 1080p FHD in 30fps and 60fps Best Settings (OBS Studio Tutorial)_Nov 25, 2020 AWAL 26 0 2 64Bit
670 OBS Studio How to Record your Screen Monitor Display (OBS Studio Tutorial)_ Nov 13, 2020 AWAL 26 0 2
700 OBS Studio Webcam How to Resize, Crop, Flip, Move, Fullscreen and Transform (OBS Studio Tutorial)_ Nov 17, 2020 WAL 26 0 2 64Bit
709 start with 2 monitors OBS Studio How to Add a Display Capture multi Monitor Screen (OBS Studio Tutorial)_Nov 5, 2020 AWAL 26 02 64Bit
710 OBS Studio How to steal and Play a Video (OBS Studio Tutorial) How to Use OBS Guide & Settings_Oct 31, 2020 AWAL 26 02 64Bit
660 levels Properties sound control panel OBS Studio Add a usb Microphone How to Use OBS Guide and Settings_ Nov 3, 2020 Awal 26 0 2
700 OBS Studio How to Add a Noise Gate Audio Filter to your Mic (OBS Studio Tutorial)_Oct 24, 2020 AWAL 24 Oct 2020 ZyqigRDwZAY 26 0 2
740 Sound Panel What available How to Add Desktop Audio Audio Output Capture Mixer Start_Nov 7, 2020 AWAL JB65JxkmLXE 26 0 2 64Bit
OBS Studio 26.1 Dec 14, 2020
400 How to use NVIDIA RTX Broadcast Noise reduction Kevin 26 1 1 680 NVIDIA RTX GTX GPU Broadcast Noise reduction Kevin Jan 14, 2021_X0J-nO74ELA

690 How to Setup OBS Portable Mode_Nov 14, 2021 K7WqZ9848U8 MachDaena 27 1 3
710 OBS STUDIO im PORTABLE MODE_Dec 22, 2021 27 1 3 BA_1PMMlSmA
550 PORTABLE OBS - Take your whole OBS with you._Jan 7, 2022 27 1 3 DongoacWBFkZzI7Y
620 Perfect stream audio, EVERY time._24 March 2022 ÜPoxy 27 2 2
OBS Studio 27.2.4 Mar 30, 2022 #2
https://obsproject.com/forum/threads/obs-windows-7.159078/ The last version of OBS Studio that runs under Windows 7 is Version 27.2.4 and you can find the download page for it here: https://github.com/obsproject/obs-studio/releases/tag/27.2.4 (choppergirl, Nov 29, 2022)
https://obsproject.com/forum/threads/windows-vista-obs-download.154697/#post-585351 Sep 18, 2022 #3 not true. I been running OBS 0.659b With Browser Installer for years on Vista records and streams no problem.
I have also got OBS-Studio-21.0.1-Full-Installer to install but uninstalled right away because i like 0.659b better.

580 OBS Studio 28 The BIGGEST update we've ever seen_pCJERLBl1Nc_4 Aug, 2022 Poxy

DocAElstein

01-30-2017, 04:58 AM

;BCX;MC;ASBC

DocAElstein

01-30-2017, 04:58 AM

From about 2023
10thAniversary No windows 7 or any 32Bit
620 OBS Studio Tutorial (2023 Edition) - Full Tutorial in 6 Minutes_ Apr 10, 2023 28 0 2
710 Das BESTE OBS SETUP einrichten keine grund mehr nicht OBS PORTABLE_Oct 6, 2022 WF43kugWJvU 28 0 3
OBS Studio 28.1.2 Nov 5, 2022
740 How to Record Multiple USB Mics at Once_Dec 19, 2022 Kev Audacity 28 1 2 1vlx_5Semls

680 OBS STUDIO Bild und Ton synchron - Komplettkurs 2023 #7_28 Dec, 2022_L4MszmyJcZ0
700 A OBS Studio AUDIO FILTER Tipps und Tricks für bessere AUDIOQUALITAET (Komplettkurs 16)_RCGfY56YIzc_01 Apr,2023
700 OBS STUDIO Audio und Tonspuren - Komplettkurs 2023 #6_LC3s9v36z3Q_25 Dec 2022

OBS Studio 29.1.2 May 29 2023

http://board.eclipse.cx/viewtopic.php?t=490
https://www.patreon.com/posts/obs-29-0-x-on-7-77251944?l=de OBS 29 on Windows 7/8 (and Vista with extended kernel)
09 Jan 2023, 00:53 After an interaction with one of the OBS contributors, I decided to make this post as a fuck you. Also nobody else has figured this out yet?
OBS Studio 29.1.3 Jun 19 2023

DocAElstein

02-03-2017, 07:13 PM

DocAElstein

02-05-2017, 07:02 PM

DocAElstein

02-09-2017, 02:39 PM

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16055#post16055

1-4). Run Guarding Vision software for the first time and register the administrator ( “Super User” ) account

Simply double click on the desktop icon for the first time***, and you will be prompted to make a username and password. This is the 3rd of the 4 username and password pairs that we have to deal with. This one is reasonably easy to understand: It is simple a username and password to let you use the guarding Vision Software on a particular computer.
If you remember to check , ( or leave it checked as it usually is by default ) , the Enable Auto-login box, then you will probably never need to concern yourself with this username and password pair ever again. But never the less, it does no harm to make a note of it somewhere, just in case it is ever needed again.
https://i.postimg.cc/BQfG7T81/Register-Admin-bei-first-open-Enasble-Aut-login.jpg
https://i.postimg.cc/G3yCj7pC/Register-Administrator-Doc-AElstein-Gaudy-Punct-Exclamationmark-Star.jpg
So in the working example that I am using for this Blog (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software) this is the user name and password ( for the administrator account, ) required to log in to the Guarding Vision PC Client software on the PC that I am using for this worked example:
DocAElstein
Gaudy.!*

As far as I know, this user name and password is only held in the installed software and no where else. It is only required to open the installed software on a particular computer. So if you lose this user name and password, ( or as unfortunately does happen, the username and password is no longer recognised ), the simplest way around it is to de install the software and re install it. If you have a lot of time, an alternative is to contact Sannce Support who after a few weeks of correspondence may understand what you are asking and then guide you in a way to reset the user name and password ,
SANNCE Model: DN81BL I am using correct password. But it is no longer being accepted
https://support.sannce.com/hc/en-us/requests/1164553
Password Recovery.doc
https://app.box.com/s/9uszzgjf48t1fsbn5uhbo67y58bkakr2
61.5 KB
DN81BL I am using correct password. But it is no longer being accepted.doc
https://app.box.com/s/k9cc1zepe3nzk8atye167rhmiudonybd
202 KB
Sannce2PasswordResetCatastrohy.doc
https://app.box.com/s/85khysah0rhdpdfy9wan7ne7ubj92nn2
SADPTool.exe
https://app.box.com/s/0n78g9bh72ygtwu03acc6aothfeybwf0
36.3 MB

***Note: You may occasionally get various security or similar warnings, depending on your own various security settings, example:- https://i.postimg.cc/1z7LP6vP/Allow-Access.jpg
Usually these can be either be ignored and/ or simply agree to allow what the Guarding Vision Software to do what it is wanting to do

We now have the software running,
https://i.postimg.cc/MpHYJzYB/Initial-Guarding-Vision-Window-showing-an-Online-device.jpg
( you may occasionally get an extra Help suggestion window showing https://i.postimg.cc/g27HY1MT/Extra-Help-suggestion-Window-on-first-Gauding-Vision-use.jpg )
( The Super User name which we made on running the Guarding Vision software for the first time, ( - I chose _ DocAElstein _ ) , and that you would login with in subsequent opening, is shown in the top ribbon https://i.postimg.cc/c4JmZ3qD/Guarding-Vision-Login-user-name-Doc-AElstein-shownin-top-ribbon-above.jpg )
Note also, that for the purposes of our working examples, we have , or should have, at all times, our DVR connected to the same router/modem as the computer that is running the Guarding Vision Software. This can be seen indicated in the On Devices in the bottom window.
https://i.postimg.cc/MpHYJzYB/Initial-Guarding-Vision-Window-showing-an-Online-device.jpg
https://i.postimg.cc/jjcDv7pY/Initial-Guarding-Vision-Window-showing-Our-Online-device-SN-username.jpg
( You can also see in that shown Online Device, ( which is our DVR ) , the full long character Device Serial No. , https://i.postimg.cc/jjcDv7pY/Initial-Guarding-Vision-Window-showing-Our-Online-device-SN-username.jpg , also contains the effective 9 character user name serial number , SN , of our DVR, F53992124 , which we have discussed previously as one of the user names that we need to know about ).
( Note the use of the horizontal scroll bar to get at all the information:
https://i.postimg.cc/fWgThmLG/Online-Device-1-1.jpg https://i.postimg.cc/MH4Wb2N6/Online-Device-1-2.jpg https://i.postimg.cc/SRjSMNZ1/Online-Device-1-3.jpg )

If no Online Device is showing, then don’t go any further!!!
If our DVR is not shown, https://i.postimg.cc/nhKG5HkP/No-Online-device.jpg , then something has gone wrong, and before we go further we should check to see if we can cure this problem, https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16054&viewfull=1#post16054

All further setting up is concerned with Adding information to it to allow a PC to view in a similar way to which the monitor is used in the simplest use of the DVR (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16051)
There are two ways to do this viewing via a PC,
(ii) 2a: Local LAN Access, ( making use of a typical modern internet Modem/ Router ‘s secondary LAN / central Server type function )
(iii) 2b: Cloud P2P Remote Access ( via the internet, ( will also need a typical modern internet Modem/ Router ) )

Conclusion/ Summary of what we see initially:
We are initially looking at Device Management , and by default a Device Type has been added automatically
So we are looking by default at the Device Management , and by default a Device Type has been added automatically, but at this stage there is nothing in it, so no actual device is being manages. But we can see that a device is available in the Online Device window. It is not essential to have a device showing in the On Line window in order to manage a device, but it is helpful if we want to manage that device, as the software will automatically recognise some details relating to that device, and this will mean that we may have to add less details ourselves when managing it.
( Managing is, in the first instance , mostly concerned with + Adding it. This so called with + Add basically means making it available for use in one way or another.

https://i.postimg.cc/MpHYJzYB/Initial-Guarding-Vision-Window-showing-an-Online-device.jpg
https://i.postimg.cc/GtJvfKPs/Device-Manager.jpg
3777https://i.postimg.cc/kRGV6xpn/Device-Manager.jpg (https://postimg.cc/kRGV6xpn)

________Device Managemant
_ Device

_Device Type_

_#_Device__

DocAElstein

02-09-2017, 02:39 PM

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16054#post16054

Importance of maintaining a working LAN connection to DVR for our demonstration and working example of setting up procedures

Very important, is to have a working strong internet connection to the LAN socket via a LAN RJ45 Ethernet cable to your Router or modem, https://i.postimg.cc/wMbWK1Wm/Router-is-connected-to-computer.jpg .
If you have a successful working internet connection, the furthest most green of the lights at the front , https://i.postimg.cc/1tkMmkGW/DVR-BN81-BL-right-green-light-internet.jpg , of the DVR should flicker on., https://i.postimg.cc/W3ggnhZn/Right-Most-Light-Indicating-Internet.jpg . The brightness of this light gives an approximate indication of the strength of the signal. If you have no green light or just a weak dim light, you might consider changing the LAN RJ45 Ethernet cable , possibly to a shorter one. My experience suggests that the DVRs from Sannce require a better and stronger LAN internet connection than most average computers and other devices do. I have also had two DVRs fail / become defect/ useless , at least as far as using local PC LAN (ii) or PC Cloud P2P (iii) is concerned, when they no longer reacted to any working LAN connection ( https://support.sannce.com/hc/en-us/requests/1492131 )

We note also that different options are available to us in the Guarding Vision Software, in particular for the P2P remote availability setting up, as a result of having a LAN cable connection to the same router/ modem to which our PC is connected.

DocAElstein

02-09-2017, 02:39 PM

Link to here : https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15896&viewfull=1#post158903 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15896&viewfull=1#post15903
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software1#post15903
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post15903
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15903#post15903

1-4). Run Guarding Vision software for the first time and register the administrator account.

Introduction and discussion of the way I have chosen to proceed with the explanations
The main purpose of all my Blog here (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software) , is to get the remote Access via a (remote) PC using Guarding Vision PC Client Software
We do actually have enough information to do this , at this stage, from a remote source which is away from where the DVR. In other words, theoretically, we could proceeded as if from now on
_ we have no direct access to the DVR
and also
_ our PC has no direct ( LAN cable or WLAN wireless connection ) connection to the same router / modem to which the DVR is connected. ( But note*** , that the DVR must have a reliably working internet connection via the LAN socket to a router/modem or some other means to connect it to the internet: It must be “On line” )

In other words, we could proceed as if we were travelling “away from home” and have our PC or Laptop with us

However, it is much easier to understand, and has a better chance of initial and later success, if we proceed in a more logical progression.
In this logical progression we will in the next section remain “at home” , or physically close to the DVR.
So we are assuming that we unpacked and did the initial first quick set up and are still using the (i) most simple use of the DVR and cameras and monitor (i) (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16051) ( and have the mouse still connected to the receiver )

We will then go on to the next way, (ii) , the “local LAN way”, to use the DVR, which is local PC use of the DVR (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16052)

Finally we will go on to the P2P Cloud way, (iii) , which is the remote PC way (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16053)
We note that at this final stage we will still be coincidentally connected to the same router / modem as the DVR, but this is just because of the way we have decided to progress in order to set up the final P2P Cloud way. However, at this final point we need do no more than simply take our PC to some remote point , ( theoretically anywhere in the world!), and as long as we can connect hat PC in some way to the world wide web internet at this remote location, then if all has gone well, we should be still able to access the DVR, that is to say view using the cameras that are connected to the DVR, and the pictures should appear close to real live time on out PC screen. This last functioning arrangement is the main goal of my entire Blog here (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software ). At that point , this Blog (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software ) is finished, although note that we will discus the three different ways to get at the final P2P Cloud way: _ -A- _ -B- _ -C-

Remote ( Cloud P2P ) Access of DVR over the internet with a PC using Guarding Vision Windows PC Client Software,
2b) -A- ______ Following on from previously obtaining LAN local access, and
Adding ( making available ) DVR for remote Cloud use for the first time: DVR is not yet Registered for P2P remote Access
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15912&viewfull=1#post15912

2b) -B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15918&viewfull=1#post15918

2b) -C- Cloud P2P remote access if no Sannce registered account holds DVR information
Possible Problem! Need to remove details of DVR from Sannce registered devices
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15919&viewfull=1#post15919

***Very important, is to have a working strong internet connection to the LAN socket via a LAN RJ45 Ethernet cable to your Router or modem, https://i.postimg.cc/wMbWK1Wm/Router-is-connected-to-computer.jpg .
If you have a successful working internet connection, the furthest most green of the lights at the front , https://i.postimg.cc/1tkMmkGW/DVR-BN81-BL-right-green-light-internet.jpg , of the DVR should flicker on., https://i.postimg.cc/W3ggnhZn/Right-Most-Light-Indicating-Internet.jpg . The brightness of this light gives an approximate indication of the strength of the signal. If you have no green light or just a weak dim light, you might consider changing the LAN RJ45 Ethernet cable , possibly to a shorter one. My experience suggests that the DVRs from Sannce require a better and stronger LAN internet connection than most average computers and other devices do. I have also had two DVRs fail / become defect/ useless , at least as far as using local PC LAN (ii) or PC Cloud P2P (iii) is concerned, when they no longer reacted to any working LAN connection ( https://support.sannce.com/hc/en-us/requests/1492131 )

DocAElstein

02-09-2017, 04:43 PM

This is page 3, post #21
https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)/page3 https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)/page3
Thread number #post23438
https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)?p=23438&viewfull=1#post23438 https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)?p=23438&viewfull=1#post23438
https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)/page3#post23438 https://www.excelfox.com/forum/showthread.php/2935-Test-Video-YouTube-Video-making-and-editing-etc-coupled-to-excelfox-(OBS)/page3#post23438

Try Releases 17.0.2 32Bit (Jan 19, 2017 ) Portable

From here https://github.com/obsproject/obs-studio/releases/tag/17.0.2
https://i.postimg.cc/7hBrYzXN/Releases-17-0-2-Full-zip.jpg https://i.postimg.cc/gL6TgnCw/Releases-17-0-2-Full-zip.jpg (https://postimg.cc/gL6TgnCw)
OBS-Studio-17.0.2-Full.zip https://drive.google.com/file/d/1T-eefdP3IyH0OCELFEBhkyCLj6UOPLsg/view?usp=drive_web
https://drive.google.com/file/d/1T-eefdP3IyH0OCELFEBhkyCLj6UOPLsg/view?usp=drive_web

DocAElstein

02-09-2017, 04:46 PM

Try Releases 17.0.2 (32Bit) (Jan 19, 2017 ) Portable

Get it
We get the .zip thing containing it all from somewhere. Here a few ideas,
Either
from the OBS GitHub releases page
https://github.com/obsproject/obs-studio/releases/tag/17.0.2
https://i.postimg.cc/7hBrYzXN/Releases-17-0-2-Full-zip.jpg https://i.postimg.cc/gL6TgnCw/Releases-17-0-2-Full-zip.jpg (https://postimg.cc/gL6TgnCw)
Or, here I have it in a few places :
Share ‘OBS-Studio-17.0.2-Full.zip’ https://app.box.com/s/qyxynp8893cvftdhmmzg90brobdji44w
OBS-Studio-17.0.2-Full.zip https://magentacloud.de/s/f5bnBsydskLqQMQ
OBS-Studio-17.0.2-Full.zip https://drive.google.com/file/d/1T-eefdP3IyH0OCELFEBhkyCLj6UOPLsg/view?usp=drive_web

Unzip it
The word zip may not explain things so well. A .zip file seems to be a file squashed or compressed to reduce its size, but die to this it is not much use in that squashed form. It is often represented by a Folder symbol with a zip in the middle. So maybe it is finally something like a folder with all the stuff we want squashed in it, like sardines in a sardine tin. I will call it a zip Folder/File thing.
So once we have the zip Folder/File thing we need to put it back to its more useful unsquashed form , - that is often referred to as unzipping it.
There seem to be a few ways to do this. In newer windows it seems to happen automatically if you go into the .zip folder like zip Folder/File thing, and either drag the contents somewhere or copy them and paste them somewhere. I often copy the contents and paste them back in the same real folder holding the zip Folder/File thing. So I end up with the zip Folder/File thing and the useful unsquashed version of the files that were in it.

This sort of set of actions for example to Get it and unzip it( This example I get it from the GitHub OBS releases page):
Download the zip Folder/File thing into some convenient normal folder, ( on a USB stick ) https://i.postimg.cc/5yPxsZwm/10-download.jpg
https://i.postimg.cc/GmTcjg9k/20-downloaded.jpg
Take a look inside the zip Folder/File thing by double clicking on it https://i.postimg.cc/Gp0bgPs6/30-look-inside-it.jpg
Copy or drag the contents back into the normal Folder https://i.postimg.cc/pTRRR2CZ/40-drag-or-copy-it-back.jpg
https://i.postimg.cc/j2jTnZGn/50-being-copied-back-to-main-folder.jpg
You should end then with something like this https://i.postimg.cc/vBhMmpSd/60-Copied-back-to-normal-Folder.jpg

DocAElstein

02-09-2017, 04:48 PM

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15906#post15906

Make Entry for Standard local Device - + Add an actual type to the standard type management presented to us by default
So , as explained in the last post, (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15905&viewfull=1#post15905) on opening Guarding Vision software for the first time, a device type had been added automatically. We could call this a local or standard device.
A Standard device could be any directly / locally connected device, so can include our PC LAN Access

One way to make this entry is to use the +Add button of the large window (https://i.postimg.cc/cLMT1VMd/Large-Device-for-Management-Window.jpg) in which things are written in / Added
https://i.postimg.cc/sxXB3wbK/Add-Button.jpg https://i.postimg.cc/tTDZ0LvY/Add-a-specific-device-Button.jpg
That is a fully acceptable way to Add a particular device, but as we have an Online Device showing in the Online Device window below , ( which is the one we want to Add ) , we can take advantage of the button by the Online Device window to add that device. This way has the advantage of adding in some of the details for us: The basic entry dialogue boy that comes up is identical to that which comes up with the standard Add button of the large window , but on opening after using the +Add to Client button, some of the entries will be already written for us: https://i.postimg.cc/XvfBLZwK/Add-a-specific-device-from-Online-devices-using-Add-to-Client-Button.jpg – Specifically the local address in our LAN network of our DVR , 192.168.2.100
We need to write in two entries, the User name and Password pair, which we discussed as the first user name and password pair that we met , which we named “ userame and password pair by first time DVR with Monitor, and needed in later LAN use on a computer (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16050)“
admin
Sannce.!*
( We also need to add a “Nickname” of our choice. This will be used as a name on any button to select this device. It can be any name we chose. I personally prefer to use something to help remind me what it is referring to, something like
DVR_LAN _ DN81BL _F53992124

So we fill in the three bars and hit the Add button in the Add dialogue box, https://i.postimg.cc/vZ6V12TN/Add-a-specific-device-from-Online-devices-using-Add-to-Client-Button.jpg
https://i.postimg.cc/3wYFHdJv/Fill-in-details-then-LAN-add.jpg
Since we are accessing a local directly connected device, this connection/Adding process , ( typically referred to as Importing ) will usually be very quick.
A small black window bottom right to confirm the success will typically pop up just for a very short time , https://i.postimg.cc/q7VC2cCM/Importing-Succeeded.jpg , and this ,along with the details appearing in the main window including the Net Status** symbol indicating a working connection, https://i.postimg.cc/GhfDmnLD/Net-Status-Good.jpg , will mean that almost certainly we can view our cameras now on our computer. This viewing is always done in a similar way for any added devices, but note that after the first viewing there is a small change to allow quicker viewing on any subsequent viewing. More detail on this viewing in the next post.

Summary: Our first ( device management ) action
So, at this stage, we opened the Guarding Vision PC Client Software for the first time, which by default had added a device type, ( a simple local device type) , and we had an online device showing, ( - our DVR was showing because we had connected it via a LAN cable to the same modem/router as our computer).
Because our DVR was showing as an online device, this simplified the adding of a particular simple local device, our DVR, which we did in this post.

We are not viewing anything yet on our computer, as we have just done some managing of the DVR. ( The next post takes the simple steps to now actually do our first viewing with a computer )

https://i.postimg.cc/g2vH5vdp/Finished-first-use-of-Device-Management-added-the-online-LAN-device.jpg https://i.postimg.cc/BQtDWR94/Finished-first-use-of-Device-Management-added-the-online-LAN-device.jpg
37783779

https://i.postimg.cc/4YxcHHm2/Finished-first-use-of-Device-Management-added-the-online-LAN-device.jpg (https://postimg.cc/4YxcHHm2)https://i.postimg.cc/dLPDrHVx/Finished-first-use-of-Device-Management-added-the-online-LAN-device.jpg (https://postimg.cc/dLPDrHVx)

( Note in those last screenshots we have scrolled to the right in the second ( right ) screenshot to get all information )

( **Note , incidentally, that the Net Status is referring to the online status of the computer, and is not an indication of the status of the LAN cable connection to the DVR . ( Should the computer go off line, the Net Status will change thus: https://i.postimg.cc/637LBrgr/Net-Status-Computer-Offline.jpg ) )

DocAElstein

02-09-2017, 04:57 PM

Viewing cameras on Computer ( for first time )

The viewing on a computer via Guarding Vision Software, of a camera , or cameras, which are connected to the DVR can be done at any subsequent time via the uppermost small View tab,
https://i.postimg.cc/SK2nSyVY/View-Main-View-first-use.jpg

View

_#_Main View______

,( but note that after the first time of taking this action , an extra larger Main View main tab will appear and from then on it is always there , https://i.postimg.cc/rp5GgCWp/New-Main-View-tab-appears-after-first-use-of-View.jpg )

_#_Main View_

The + and - ,
https://i.postimg.cc/2jGwPwtb/Main-View-Showing.jpg https://i.postimg.cc/HsPtLLdT/Main-View-Showing.jpg
,are an indication of an added device.

( If we were to Delete this device, https://i.postimg.cc/8cZmMpvB/Delete-device.jpg , the entry remains when Viewing , but we lose the camera view and the drop down list resulting in no indicated + or - , https://i.postimg.cc/sxyx45z5/No-view-No-drop-down-list-No-shown.jpg

If , after Deleteing a device, we re add it using the same Nickname then we will not get a duplicate entry in any View window: In general any Nickname appearing will remain there, and having or not having the + or - is the indication of whether that named device is actually available/ has been Added

The Software will in general always be cycling through to keep the camera views updated / refreshed. This process can often get stuck, or it may be slowly checking through all camera ports on the DVR, even those to which no camera is connected . To “wake up” the system we have the possibility to refresh/ restart a camera group, https://i.postimg.cc/pLhJ5tLz/Main-View-Re-start-cycle-view-possibility.jpg ,or alternatively a double click on a camera from the groups drop down list, https://i.postimg.cc/fLYkdBGw/double-click-on-a-camerato-wake-up.jpg , will also act to “wake up” / re start the viewing using that particular camera, https://i.postimg.cc/mrvth06X/double-click-on-a-camera-to-wake-it-up.jpg

DocAElstein

02-09-2017, 04:58 PM

_________

DocAElstein

02-09-2017, 05:05 PM

_________________

DocAElstein

02-09-2017, 05:10 PM

Page 3 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910&viewfull=1#post15910 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910&viewfull=1#post15910
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910&viewfull=1#post15910 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910&viewfull=1#post15910

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910#post15910 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15910#post15910

Step 2b: P2P Access
2b) Remote ( Cloud P2P ) Access of DVR over the internet with a PC using Guarding Vision Windows PC Client Software

Step 2b: P2P Access Remote ( Cloud P2P ) Access of DVR over the internet with a PC using Guarding Vision Windows PC Client Software

Most published instructions for Remote ( Cloud P2P ) Access of the Sannce DVR over the internet with a PC using Guarding Vision Windows PC Client Software are incomplete or incorrect. ( Example the section from Step 2b: P2P Access at the following Sannce article is wrong and incomplete, https://support.sannce.com/hc/en-us/articles/900000422223-Sannce-Home-How-to-view-the-cameras-on-the-computer-via-the-software-Guarding-Vision-
Similarly the Sannce article here , https://help.annke.com/hc/en-us/articles/4405215514905 , is incorrect

2b)
Remote ( Cloud P2P ) Access of DVR over the internet with a PC using Guarding Vision Windows PC Client Software,
2b) -A- ______ Following on from previously obtaining LAN local access, and
Adding ( making available ) DVR for remote Cloud use for the first time: DVR is not yet Registered for P2P remote Access
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15912&viewfull=1#post15912

2b) -B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15918&viewfull=1#post15918

2b) -C- Cloud P2P remote access if no Sannce registered account holds DVR information
Possible Problem! Need to remove details of DVR from Sannce registered devices
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15919&viewfull=1#post15919

DocAElstein

12-29-2017, 12:20 AM

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16060#post16060

Advise of preparations for encountering 4th username/ password pair for the first time,
( the Sannce P2P account Registering process )
Sannce organise something like a central register/ data storage facility, making it possible for various technical details required for remote P2P type internet usage of you DVR to be stored and accessed. P2P technology: https://en.wikipedia.org/wiki/Peer-to-peer
https://en.wikipedia.org/wiki/Peer-to-peer_file_sharing
https://en.wikipedia.org/wiki/Anonymous_P2P
The Sannce DVR model in use with the Guarding Vision Software on a PC, insists that you use such an account if you wish to use the P2P remote access possibility with your DVR to get access to your DVR over the internet ( from anywhere in the world ) using the world wide web internet. (https://en.wikipedia.org/wiki/World_Wide_Web)
You necessarily need to register such an account, and typically you will be asked to register such an account when using the Guarding Vision Software on your computer.
It’s free and there is no limit to how many account you can have. But the registering is full of problems and bugs. Many of these problems and bugs seem to get worse if you do not do the registering quickly. Hence one of the main reasons for this post is to prepare all you need before hand so as to improve your chances of a successful registration.

If for any reason your registration fails , you will most likely not be able to use the username and Email address that you tried to Register with ever again in a Sannce P2P Registration. Therefore I recommend preparing at least two full sets of the three things you need. Put them in a text file or in some other place where you can get at them easily and quickly when you are using your computer for the registration. These three things are
]_Username
_Password
_ Email address[/FONT]
For reasons of which I do not yet fully understand, some character combinations and Email addresses work better than others.
I would recommend therefore using similar ones to the example that I give.
I would further recommend using gmail Email address.
I would recommend keeping the gmail username as short as possible. I would recommend making at least 2 spare new gmail accounts initially.
I would recommend using a Username and gmail username that is not important to you, at least in your first attempts. - The main reason why I recommend this is that if for any reason your registration fails , which it often does, then you will most likely not be able to use the username and Email address that you tried to Register with ever again in a Sannce P2P Registration. Possibly later, once you are more comfortable and have possibly mastered the registering successfully, you could then risk using a preferred Username and gmail address.

I would recommend you register beforehand at least 2 gmail Email accounts ( https://accounts.google.com/signup/v2/webcreateaccount?hl=en&flowName=GlifWebSignIn&flowEntry=SignUp ) , and then prepare a text file , .txt , or Word file , .doc , looking something like the following example. In this following example I have two complete lists of the info needed to register , and in addition I have also included the 2nd username and password pair. There are no great problems associated with using this other pair, but as they are often needed shortly after registering, it is convenient to have them at hand along with the other information

Register Account ( Annke Sannce Registered Vision Guarding Vision Cloud P2P App Sannce Home Account User Name and Password by Email Address )
User Name cloudplop
Password SangyP2P.!*
Confirm Password SangyP2P.!*
Email Address poo2peey@gmail.com

Register Account ( Annke Sannce Registered Vision Guarding Vision Cloud P2P App Sannce Home Account User Name and Password by Email Address )
User Name cloudpooh
Password SangyP2P.!*
Confirm Password SangyP2P.!*
Email Address plop2pee@gmail.com

Remote Enabled DVR serial No.Sannce Home Verification Code2
Username DVR SN. F12345678
Enabled Password verification code Sanky2

So when prompted to register, this would be the relevant things to write in or paste in
cloudplop
SangyP2P.!*
SangyP2P.!*
poo2peey@gmail.com

If anything went wring, then I would not attempt to use the Username or Email address again , ( there is no problem in trying the password again ) , so I would start again with this
cloudpooh
SangyP2P.!*
SangyP2P.!*
plop2pee@gmail.com

Here are three screenshots of the typical Registration process: Initially a window indicates the 4 main full width fields that need to be filled in , the username, the password ( twice ) and an Email address. After filling in all 4 fields, you should click on Send Message. This should send an Email to the Email address containing a number. That number should be entered in the bottom left half width field, and then finally you click on Register https://i.postimg.cc/15QXxWV4/3-pics-from-Register-window.jpg
3780 https://i.postimg.cc/8sZNMmHV/3-pics-from-Register-window.jpg (https://postimg.cc/8sZNMmHV)

Often after registering, I would be doing something requiring me to do a so called “ + Adding” of a device ( usually the device would be my DVR ). I would then be asked to fill in one or more of two fields ( in some situations the first field would be already filled in )
The information I would then need to give would either be the second or both of these
F12345678
Sanky2

Some typical problems
In the next screenshot, the all the usernames and Email addresses are known to have never resulted in a successful Register of an account. Originally they ere accepted but the final registration failed, for example due to the not being able to be completed within a certain time. So no registered account uses any of the usernames and Email addresses.
Despite trying different computers, Browsers, waiting several days, deleting cookies , Browser history, etc, attempting to use the usernames and Email addresses always resulted in rejection
https://i.postimg.cc/rydPvrDP/Username-or-EMail-cant-be-used-even-though-they-are-not-used-in-any-existing-account.jpg

The next screenshot shows that the length of an accepted Email address is limited. A valid gmail Email address was pasted in , but the field only took a limited number of characters, which did not include those containing the email provider, and hence an invalid Email address was indicated
https://i.postimg.cc/Fz35mdH3/Does-not-like-long-EMail-name.jpg

The next screenshot is an example of the software not recognising some Email providers: I have tried many different names, that is to say, many different valid Email addresses using the provider t-online.de ( German Telekom ) , but they are never accepted as valid Email addresses.
https://i.postimg.cc/y8wm3D1k/Does-not-like-t-online-de.jpg

DocAElstein

12-29-2017, 12:20 AM

___________________________________

DocAElstein

12-29-2017, 12:20 AM

Post #22 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15911#post15911

Some further discussions on account usernames and passwords, and preparation for Sannce P2P account Registration
(4th username / password pair ( and 2nd username / password pair ) )
The 4 basic password/ username pairs were introduced here: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software#post16050
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16050&viewfull=1#post16050

This post attempts to both
_ clarify the situation related to the password/ username pairs which I numbered/ refer to as 2nd and 4th.
_ to advise of preparations for encountering 4th for the first time, ( the Sannce P2P account Registering process ), since typically it can be full of problems and bugs.

The 4th and final encountered password/ username pairs can sometimes be confused with the second, and they are related.
As far as I can tell the 4th password/ username pair relates to an account to gain access to some remote cloud type storage either at, or organised, by Sannce. With this account you can arrange that details of a DVR are held at this storage. Those details make it possible to make a P2P remote connection.
There is , in the first instance**, no limit to the number of such a Sannce P2P account that you can have. There is also no requirement to have made any payment or purchase.
You could probably compare some aspects of the Registering process of such an account with the registering of a gmail Email account. In fact you will need an Email account during to the Registering process. The Registering process can be very tricky, - not all usernames and passwords and Email accounts may work. A gmail account has a good chance to work.
There are other bugs and problems. The biggest problem, in short, is: If for any reason your registration fails , which it often does, then you will most likely not be able to use the username and Email address that you tried to Register with ever again in a Sannce P2P Registration.

Clarification of the situation related to the password/ username pairs which I numbered 2 and 4. ( and 1 )
I named the “2nd password and username” pair the 2nd … _ pair because you encounter it typically very early on, just after you encounter the very first, most fundamental password and username pair . ( The first most fundamental pair is that which you need in order to
_ do anything in the settings of your DVR in a direct way via a mouse and monitor
, and you also you
_ need it for the simplest way ( local LAN access ) to access the DVR with a computer ,- what you might call a local or semi-remote way )
The second password and username you encounter early on, even if you follow any simple “quick start” or “Quick Operation Guide”, is not typically referred to as a password and username. It could be consider as the password and username required for accessing the DVR in a truly remote way. This truly remote way could be considered as meaning
_ remote access in some way across the world wide web internet – your DVR and computer are separated by a large physical distance and there is no simple direct connection either by a cable or a local wireless system or Local Wireless Area Network
Just for comparison , a local or semi-remote way could be considered as meaning
_ access via a computer “locally” – LAN type access – when your computer and DVR are connected to the same router or modem or server or are in some other way connected to the same Local Area Network

Just a quick clarify on that last stuff:

_1st username password pair_________________ 2nd username password pair
__ Monitor __________Computer________________________________ Computer
__ DVR---Monitor______DVR-modem/router-Computer___________________ DVR-modem---Internet(P2P)-----modem-Computer
__HDMI or VGA _________local__________________________________re mote
Cable connection____LAN (Ethernet cable) __________( computer can be physically a large distance away from DVR )
_______________________WLAN_______________________ _______ world wide web Internet

The final 4th username and password is required for a particular way ( P2P via Sannce ) of the truly remote way and so the 2nd username and/or password may be required at times when the final 4th username and password is required. This is one reason why these two are sometimes confused with each other. The 2nd is concerned with the decision to allow such use. The 4th is concerned with the authority of holding of the technical information needed to make it possible. This is possibly a strange idea and concept. Hence another reason easy to get confused.
Another reason for the confusion is that at the time that you ( often unconsciously ) set the password of the 2nd username and password pair, there may be a reference to Sannce or Sannce Home. For example this is a screen shot from approximately the 5th – 9th screen view that you see during the initial quick set up on first use of your DVR connectred to a Monitor.
( Which screenshot it is may vary slightly on what options you take or what exact DVR model you have ) .
( This is also a screenshot that you can get at later via settings using a mouse and the monitor )
https://i.postimg.cc/jq39qtVF/Enable-remote-use-of-DVR-and-give-password-for-that-remote-use.jpg
You will see in that screen got the word Sannce Home, whereas I would suggest a more appropriate thing to use would be something like “Remote Access Password”
Typically when following a “quick start” or “Quick Operation Guide” , you would check the Enable box , and then chose a Verification Code. I chose arbitrarily Sannce2 , abd that becomes what I refer to as the password in the 2nd username and password pair. I would suggest a more appropriate thing to use rather than Verification Code would be something like “Password” followed by some note saying that the corresponding username is the part number of your DVR.
Usually when you fill in the details when following a “quick start” or “Quick Operation Guide” it is not obvious what is going on there: This is what you are actually doing:
_Checking Enable allows the DVR to be used remotely , ( that is to say via a computer rather than just with a monitor directly connected to the DVR with a HDMI or VGA cable )
_ when you set up the P2P remote usage, in Guarding Vision software, you will be asked to fill in two entries in a typical log in type pop up. https://i.postimg.cc/V6tQTWFm/Fill-in-Serial-Number-and-Verification-Code.jpg https://i.postimg.cc/4Nktr4Xg/Second-uesrname-password-pair.jpg
https://i.postimg.cc/Jhvc0NCy/Add-To-List-P2-P.jpg
The first entry may be referred to as the username or serial number or device name , and the second entry may be referred to as the Verification Code or password. My DVR has on the underside on a label something written like SN: F53992124
So in all my discussions I have 2nd username and password pair of
F53992124
Sannce2

Advise of preparations for encountering 4th username/ password pair for the first time, ( the Sannce P2P account Registering process )
_.... see next post

DocAElstein

12-29-2017, 12:20 AM

____________________________

DocAElstein

02-07-2018, 03:49 PM

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15912#post15912

Remote ( Cloud P2P ) Access of DVR over the internet with a PC using Guarding Vision Windows PC Client Software,
2b) -A- ______ Following on from previously obtaining LAN local access, and
Adding ( making available ) DVR for remote Cloud use for the first time: DVR is not yet Registered for P2P remote Access
In this explanation version 2b)–A- , we are following on from having just made available ( Added ) , the DVR for the local LAN viewing way . As noted previously, we don’t need to do have just done that, but this can help simplify the explanation, especially for a first time setting up of the Cloud 2P2 remote way

So initially we are still managing and seeing information related to the available standard local LAN Device. In our working example, the particular standard local LAN Device that we have been considering is the DVR connected via a LAN RJ45 Ethernet cable to our router/modem. This device is still showing in the Online Device window.
https://i.postimg.cc/yNQGbbVP/Online-Device-window.jpg
( The Online Device window is independent of anything else that we are doing and simply shows and gives various details about any device that is connected to the same router/ modem as the computer running the Guarding Vision Software, and specifically any devices that the Guarding Vision Software recognises as a DVR or any other device which it thinks may be of interest to us. ( You will not necessarily see all other devices such as other computers connected to the same router/ modem ) )

Add a New Device Type of the Cloud P2P type
Our first step is to Add a New Device Type of the Cloud P2P type. Unlike the case of the standard LAN local device type, the Guarding Vision Software does not have one of the Cloud P2P types added by default. I don’t know why that is. I see no obvious reason: All any device type shown in the Device is , is a button on which to call in the process to allow adding a particular device of that type. Never mind

So we follow a similar procedure as for the local LAN device case, to add a new device type, the only difference being that in the dialogue window that pops up, we now check the Cloud P2P Device check box https://i.postimg.cc/mgb3v0sM/Add-New-Cloud-P2-P-Device-Type-for-the-first-time.jpg ( In this example we are assuming that no cloud P2P device type has ever been added, and so the Cloud P2P Device check box would typically not be checked by default )
This last action by us causes a new device type to appear
_#_ Cloud P2P Device ____

But note that at the present time we are still looking at and managing the local LAN connected DVR, https://i.postimg.cc/ZR1FXnbK/but-still-viewing-and-managing-the-local-connected-LAN-DVR.jpg

________Device Managemant
_ Device

_Device Type

_#_Device ___________

_#_Upgrade Server _____

_#_ Cloud P2P Device ____

https://i.postimg.cc/xTPqWGgG/Added-P2-P-Device-Type-but-not-highlighted.jpg
3782https://i.postimg.cc/6yy9ZvkT/Added-P2-P-Device-Type-but-not-highlighted.jpg (https://postimg.cc/6yy9ZvkT)

Once again, note that in that last screenshot we see the new Cloud P2P Device Type appear in the left margin device type window , but it is not highlighted, so that at the present time we are still looking at and managing the local LAN connected DVR, https://i.postimg.cc/ZR1FXnbK/but-still-viewing-and-managing-the-local-connected-LAN-DVR.jpg

Click on the Cloud P2P Device type to set off….. ….
If we now click on/ select the new Cloud P2P Device Type , you may see for a split second the highlighting in the Device window change to

________Device Managemant
_ Device

_Device Type

_#_Device ___________

_#_Upgrade Server _____

_#_ Cloud P2P Device ____

But that may occur too quickly to see, -. but what should open, and stay open, and fill most of the screen, is a large Login window pop up: What is happening is that the device management is interrupted , because you cannot manage a P2P device without logging in to an authorised account………
https://i.postimg.cc/ryr9x1jd/select-the-Cloud-P2-P-Device-Type-a-login-will-appear.jpg
https://i.postimg.cc/KvF8F0Sb/mceclip3-Login-country.png

We are now ready for considering the registration of this final , 4th , of the 4 username and password pairs associated with the Sannce DVR using Guarding Vision Software.

( At this point, if you have not already done so, its worth reading the extra notes about this last user name and password which you need to know about, here https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15911&viewfull=1#post15911 )

DocAElstein

02-08-2018, 12:53 AM

Register Sannce P2P Account First Registration of an account for the.. …. Annke Sannce Registered Vision Guarding Vision Cloud P2P App Account User Name and Password by Email Address ….

So, If we now click on/ select the new Cloud P2P Device Type , we will initially see a large Login window pop up
https://i.postimg.cc/ryr9x1jd/select-the-Cloud-P2-P-Device-Type-a-login-will-appear.jpg https://i.postimg.cc/KvF8F0Sb/mceclip3-Login-country.png
You should select a country, and remember it. It is probably best to always use your country, where the DVR is located. https://i.postimg.cc/SsXfZCpv/select-your-region-then-login.jpg ( More on that later ).
Register ( a Annke Sannce Registered Vision Guarding Vision Cloud P2P App Account User Name and Password by Email Address )
Because we are doing this for the first time, and assuming we are new to anything to do with Sannce, we will need at this point not to log in yet, but instead, to register an account as discussed in the last post (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15911&viewfull=1#post15911)
Note once again also that we assume that
either
_no other account has made available to Cloud P2P access our DVR
Or
_ if our DVR has been in the past made available to Cloud P2P access using an account, then that account has then at some later date logged in and removed (Deleted) the account so that it is not available at the time that we will make it available.
If our DVR has been in the past made available to Cloud P2P access using an account but has not been removed from availability (Deleted) , this fact will not prevent us registering an account, but it will prevent us using the account ( or any other account ) to make our DVR available to us using Cloud P2P access.

Register and then log in
Having entered the large window , https://i.postimg.cc/KvF8F0Sb/mceclip3-Login-country.png , select the region where the DVR is
https://i.postimg.cc/SsXfZCpv/select-your-region-then-login.jpg
Because this is the first time we are trying to doing anything related to P2P accounts, it is unlikely that we have ever registered an account of the type required, so we ignore the upper logging in part and concentrate on the lower half
https://i.postimg.cc/2StxPbqs/Register-Annke-Sannce-account-thing.jpg
https://i.postimg.cc/rmkS57Ym/Lower-Register-half-of-Sannke-Annke-Vision-Guarding-Vision-Cloud-P2-P-App-Account-User-Name-and-Passw.jpg

You need to add details quickly,
https://i.postimg.cc/8zcHKBCd/Register-Annke-Sannce-account-thing.jpg
, and then click on Send Message

__Send Message_

https://i.postimg.cc/MZcZJt6P/Send-Message-in-Registration.jpg
Usually a number code arrives fairly quickly, at the given Email address https://i.postimg.cc/6pBNqhKN/Verification-Code-billgelatine-ATgmail-DOTcom-In-Box.jpg
https://i.postimg.cc/BQT0JVdg/Verification-Code-billgelatine-ATgmail-DOTcom-In-Box.jpg
https://i.postimg.cc/bNcPchFr/Verification-Code-billgelatine-ATgmail-DOTcom-In-Box.jpg
, and this in turn should be quickly typed in, https://i.postimg.cc/902LbJJm/Type-recieved-code-in-quickly.jpg , and finally click the Register

_______Register_______

https://i.postimg.cc/W4KKGGBz/All-details-filled-in-so-Register.jpg

Assuming the registration has gone OK, you can now use the upper part of the login/register window to log in
https://i.postimg.cc/6p8fdktV/Login-after-Register.jpg
https://i.postimg.cc/TPmjsnyp/Login-after-Register-using-upper-half.jpg
You will probably get a warning that you have no resources to import.
https://i.postimg.cc/FR3GbrH2/Loging-in-after-Register-Warning-no-resource-to-import.jpg
That is as expected at this stage. It is because the account has not made any CloudP2P availability yet. – In simple terms, you have done nothing yet with this account, so there is nothing of significance that needs to be done when you log in. ( - We will see later, that it is the act of logging in that, as a by product, makes a connection ( “imports resources to/ for ” ) availability/ possibility into the computer to/ of access via P2P internet remote. What resources/ possibilities your lodging in makes available will depend on what you have previously done using this account, that is to say, depending on what you have done when logged in with this account
The technical processes are not clear of what actually is happening, hence the rather unclear use of wording by me here.

Using Registered account to set up P2P connection
Being logged in with a valid account basically makes it possible to make available to the internet the P2P remote access of a DVR. (Once this has been done with a particular account, then no other account may do the same, until that particular account is used to remove that availability . But you can, on any other computer , on any other running application of the Guarding Vision software , log in with that same particular account ( if you know the user name and password) , and this logging in will automatically make the same availability to you on that other computer where you log in)

As a result of logging in, the Cloud P2P Device _ Type is highlighted, or rather it still is highlighted , since it was highlighted for a split second, as you clicked it/ selected it, ( but which caused the login/ register windows to pop up)
https://i.postimg.cc/cJLmnPkZ/After-Cloud-login-we-are-managing-cloud-devices.jpg

________Device Managemant
_ Device

_Device Type

_#_Device ___________

_#_Upgrade Server _____

_#_ Cloud P2P Device ____

Because the Cloud P2P Device _ Type is highlighted, we are effectively managing CloudP2P type devices, but nothing is showing yet, as we have done nothing yet.
Also in the Main View, whilst you will see a folder appearing for any account that is , ( or has been at any time ) , logged in , as well as any other devices,
https://i.postimg.cc/dVp7qqtZ/Folders-no-or.jpg
https://i.postimg.cc/43cYyrmL/Folders-no-or.jpg
you will not see any + or – showing to the left of it. – There are no “resources” , that is to say, no cameras in it, nothing to see in it.
Just to clarify: In that last screenshot, we see an entry for the previously added local LAN availability , which we had given the “Nickname” DVR_LAN_BN81BL_F53992124 and we also have a + in order to open that folder to reveal the camera “resources”
We also see both the currently logged in account which we just made, cloudp2pee, and an account that is not logged in which I had logged in with some time previously, cloudygirlp2pssd
Neither of the two Cloud P2P accounts have any Added / made available devices: For our new account, cloudp2pee we have done nothing with it yet, ( and with cloudygirlp2pssd , I had added resources, but then deleted them.
( Having or not having the availability in the Guarding Vision software, that is to say having a devices detail added or not, will determine whether or not the folder has a + or – showing to the left of it. But that does not guarantee that we get pictures displayed. That will depend on whether the DVR has a working connection to
_ the same router/ modem as that which is connected to our computer, for the local LAN devices
or
_ a reliable internet connection of some form, for the Cloud P2P devices. ( In this latter case it does not need to be, but can be, a connection via the same router/ modem as that which is connected to our computer )

So at this stage we don’t see anything yet,…_
https://i.postimg.cc/7Lxqyjsm/Not-yet-seeing-anything-by-P2-P.jpg https://i.postimg.cc/fynhbFW3/Not-yet-seeing-anything-by-P2-P.jpg
3784https://i.postimg.cc/ygPGQLZB/Not-yet-seeing-anything-by-P2-P.jpg (https://postimg.cc/ygPGQLZB)_... But we are ready now to look at the 3 ways to get the P2P access working to give us pictures

DocAElstein

02-12-2018, 08:38 PM

Make Entry for Cloud P2P Device( -A- DVR still LAN connected)
Because we are in explanation version -A- , ( the DVR is still connected in local LAN mode ) the explanations in this post are very similar to the corresponding explanations for the local LAN mode case https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15906&viewfull=1#post15906

One way to make the necerssary entry is to use the +Add Device button of the large window (https://i.postimg.cc/LXsxbNP2/Large-Device-for-Management-Window-P2-P.jpg) in which things are written in / Added
That is a fully acceptable way to Add a particular device, but as we have an Online Device showing in the Online Device window below , ( which is the one we want to Add ) , we can take advantage of the ( + Add to Account ) button by the Online Device window to add that device. (https://i.postimg.cc/BnkkLkkm/button-by-the-Online-Device-window-to-add-that-device.jpg ) This way has the advantage of adding one of the details for us:
The dialogue box that comes up for this P2P Cloud case is much simpler than in the local LAN mode case ( https://i.postimg.cc/tTDZ0LvY/Add-a-specific-device-Button.jpg https://i.postimg.cc/vZ6V12TN/Add-a-specific-device-from-Online-devices-using-Add-to-Client-Button.jpg )
This is the window that comes up from the +Add Device button of the large window (https://i.postimg.cc/LXsxbNP2/Large-Device-for-Management-Window-P2-P.jpg)
https://i.postimg.cc/RCWPfX18/Add-Device-P2-P.jpg
and this from the using the +Add to Account button in the Online Device Window (https://i.postimg.cc/SQvzK8rm/Online-Device-window-P2-P.jpg)
https://i.postimg.cc/X7FQ1qzk/Add-To-List-P2-P.jpg
They are much simpler than the corresponding window for the LAN case: I am not sure why that is. I think one reason might be that a lot of information is held and taken in / transferred / “imported” at the time of login***, and for some reason that information is not displayed. Why that information is “hidden” from us I don’t know.

So either of those windows need some information, specifically it’s the effective second user name and password pair which we discussed many times, such as here: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16050&viewfull=1#post16050

As discussed previously, the effective Username ( Serial No. ) is the serial number, SN, seen on a small label on the underside the DVR, and the effective password ( Verification Code ) we set on the initial use of the DVR and monitor set up, . This can also be re seen or changed via a right click of the DVR mouse to reveal the settings on the Monitor
https://i.postimg.cc/9fvcjVT2/Right-Click-on-Monitor-Settings-Network-Sannce-Home-Enabled-checked.jpg
https://i.postimg.cc/mkkjNxXc/Sannce-Verification-Code.png
https://i.postimg.cc/yx2mmD35/Right-Click-on-Monitor-Settings-Network-Sannce-Home-Enabled-checked.jpg ………
_..... From our previous discussions: (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=16050&viewfull=1#post16050) ....................... The next screenshot window is associated in a rather unobvious , cumbersome, indirect war to the important “remote P2P Cloud access pair” of user name and password
( The effective user name is not shown – that is the serial number typically on a sticker on the underside of the DVR. I gave the example for one of my DVRs as F53992124 )
The effective password for remote access is what is often referred to as the “Verification Code”, as shown in the screenshots:
https://i.postimg.cc/RVBhfgG2/21-Verification-Code.jpg https://i.postimg.cc/zDW3Vswn/22-Verification-Code-agre-to-terms.jpg https://i.postimg.cc/SRWK39QZ/23-Verification-Code.jpg https://i.postimg.cc/Gt02XKR8/24-Verification-Code-Sannce2.jpg

In those last screenshots I have personally chosen the password of Sannce2. That is just my personal choice. It is a character combination that has reliably and consistently worked for me as the “verification code”. You may try a different character combinations as you wish. But make sure you keep a note somewhere of both the serial number and the verification code.
( Sometimes this “Verification Code” might be referred to as the “Sannce Home Verification Code” - But that can confuse by being mixed up with another user name an password pair which we have not yet discussed, the “ Annke Sannce Registered Vision Guarding Vision Cloud P2P App Account User Name and Password by Email Address “ )
Following my worked example, my “remote P2P Cloud access pair” of user name and password which we will need later is, based on those last screenshots:
F53992124
Sannce2
, where as explained , the F53992124 is the serial number, SN, taken from a sticker on the underneath of the actual DVR that I have been using in the course of preparing these notes ………………………._

So , for the example I have been working through, we need to write in either of those pop up dialogue boxes
F53992124
Sannce2
https://i.postimg.cc/9z3wqWPW/Second-uesrname-password-pair.jpg
https://i.postimg.cc/B6VK45XP/Second-usesrname-password-pair.jpg
Some processing seems to be being done,
https://i.postimg.cc/RhJnF3Hs/Second-usesrname-password-pair-Processing.jpg , and I think this is storing something in the account in some remote place , since when its finished we only see the basic information: https://i.postimg.cc/3rztZmnw/Added-P2-P-Device.jpg

At this stage, my Guarding Vision Software on my computer would appear to ready to do remote P2P viewing. We know that our DVR is online, and we appear to have Guarding vision ready and set up

Common Sense, “Gesunder Menschenverstand” , tells us we are finished now. But we are not
https://i.postimg.cc/dth0RDJs/Common-sens-says-finished-I-am-not.jpg
3766https://i.postimg.cc/nCtZpFsg/Common-sens-says-finished-I-am-not.jpg (https://postimg.cc/nCtZpFsg)

https://i.postimg.cc/05WQJ7RX/Not-Quite-finished.jpg https://i.postimg.cc/rF7wfcpS/Not-Quite-finished.jpg
In that last screenshot, the working picture is coming from the LAN local device, ( which we previously chose to name DVR_DN81BL_F53992124

Not quite finished yet….
If we were now to take a look at the Main View we would still not see any + , ( or - ) alongside the folder of our current logged in user, cloudp2Pee , https://i.postimg.cc/2yKSRN7N/No-or-by-cloudp2pee.jpg https://i.postimg.cc/FzRHBHcx/No-or-by-cloudp2pee.jpg , and we cannot get any remote access. - It is not working yet!! :- If we select the folder named cloudp2pee and hit the refresh/restart symbol, https://i.postimg.cc/wv9vDVjZ/Click-and-refresh-cloudp2pee.jpg , we will get a blank screen!! https://i.postimg.cc/cHTJhnKH/Click-and-refresh-cloudp2pee-get-nothing.jpg
3767 https://i.postimg.cc/LYYR6h3K/Click-and-refresh-cloudp2pee-get-nothing.jpg (https://postimg.cc/LYYR6h3K)

At this stage nobody , at least nobody at the time of me writing this, understands what the problem is. I do, :) ….

To summarise the situation as it now stands, regarding P2P Cloud remote access. ( after Adding successfully a Cloud P2P Device. )

_...see next post

DocAElstein

02-17-2018, 05:06 PM

To summarise the situation as it now stands, regarding P2P Cloud remote access. ( after Adding successfully a particular Cloud P2P Device (cloudp2pee ). )
( Logout - Login oddity. Missing piece in the puzzle)
In the way of doing it ( -A- ) , at this stage of our worked example, we appear to have a picture showing on our computer taken from a camera which is connected to the DVR. But, important is to note that this is working by the local LAN way: If our computer was not connected to the same router/modem as our DVR, then the screen would then go blank, ( at the next refresh/restart )
Similarly, as we showed at the end of the last post , if we try to access the picture via selecting the recently added folders in the Main View Explorer window (https://i.postimg.cc/k41CYV8X/Main-View-Explorer-window.jpg) , then we end up with a blank screen, https://i.postimg.cc/cHTJhnKH/Click-and-refresh-cloudp2pee-get-nothing.jpg

However , we have done correctly and fully and successfully all we can and all we need to do get the remote cloud P2P way working

So what’s the problem?

It would appear that a registered P2P account with Sannce, ( in our worked example that with the user name of cloudp2pee ) , exists to hold information for, and to act as a form of authorisation to, access one or more DVRs remotely over the internet . Necessarily this registered P2P account with Sannce also needs to be able to collect the necessary details of the DVR which are required to allow the P2P access. Whether by design, personal choice ( of Sannce ) , or for reasons of security, most of this information is not see able, ( at least not in any easy way that I know about. . – there may be some advanced settings that, at the time of me writing this, I do not know about.). So far I have not seen a “button” or any other way to evoke the “bringing in” , or “setting up with” or “using” of this information in such a way that things start working as we want them to , or as they need to in order to get the functioning P2P remote internet access.
This is a dilemma. My guess is that not just me, but the entire technical people at Sannce have been in this dilemma, and never consciously got out of it. I will further guess, that like me, anyone that ever got this functioning P2P remote internet access had spent many frustrating hours trying, and then at some point, a random combination of events resulted in it working.

So two possible solutions

Solution 1 – This was the only known solution until I figured out solution 2.
Keep experimenting and one day you will be lucky and it will start working.

Solution 2 – I figured out that the necessary action which we are missing is referred to as something like “importing”. The software is written to carry out this importing when a valid account is logged in. ( But note , that the account must have stored somewhere, (probably at Sannce somewhere), the information .
Currently we are at the situation where the account with user name cloudp2pee holds information for, and has authorisation to, access our DVR remotely over the internet. )
All we need to do is log in with the account. But we can’t, as we are already are logged in!
So, the final solution , the last missing piece in the puzzle…… Log out , and then re log in!

DocAElstein

02-23-2018, 03:16 PM

(Logout and) Login with Sannce P2P account to import

At the point where we are in this worked example, we are logged in with a Sannce P2P account with user name cloudp2pee which holds information for, and has authorisation to, access our DVR remotely over the internet.
In Main View we see this:
https://i.postimg.cc/QCyJmWD3/Main-View-before-logout.jpg
3768https://i.postimg.cc/T5nbY1h7/Main-View-before-logout.jpg (https://postimg.cc/T5nbY1h7)

, and in Device Management we see this.
https://i.postimg.cc/fyLvYf6C/Device-Management-before-logout.jpg

Now we logout, https://i.postimg.cc/xCgRk4Fq/Logout-from-Device-Management.jpg
Because we have the Cloud P2P Device selected, we are returned to the large Sannce P2P cloud login window
https://i.postimg.cc/XJnLYbLT/Logout-returns-us-to-large-cloud-login-window-because-Cloud-P2-P-Device-selected.jpg , so then we re login https://i.postimg.cc/136LjDzM/Re-login.jpg . Typically the last username used would be remembered and written in already, https://i.postimg.cc/sDbkmT3v/Re-login-rememebers-last-account-used.jpg . Note that we are only interested in logging in, - the registration no longer concerns us, so we ignore the Register button, https://i.postimg.cc/NFzWW4TC/Re-login-Only-intersted-in-logging-in.jpg
We enter the password, and hit login, https://i.postimg.cc/KcpSkZV7/Enter-password-and-then-Log-in.jpg
Some processing appears to be happening, https://i.postimg.cc/Yq4cQ5K5/Some-processing-is-done.jpg , and then note that typically , if all has gone well, a small black window pops up for a second to inform that “Importing succeeded” https://i.postimg.cc/kG401ZVt/Importing-succeeded-bottomright-smallblack-window.jpg

Now, in Device Management we see the same as we did just before logging out.
https://i.postimg.cc/vBs1R7Mz/Device-Management-after-re-login.jpg

But the first thing we notice new in Main View is that we now have a + appearing to the left of the folder corresponding to the P2P account name , cloudp2pee https://i.postimg.cc/N0TyPChF/appeared-by-folder-for-re-loged-in-Sannce-P2-P-account.jpg

If we then
either
_ hit the restart/refresh symbol, https://i.postimg.cc/MTmnzcp8/Hit-cycle-refresh-fresh-of-re-loged-in-Sannce-P2-P-account.jpg
or
_ click on that + ,to reveal the camera “resources” in a drop down list, and then double click on the first camera listed, https://i.postimg.cc/kgL6s3pL/Hit-then-double-click-first-camera-of-re-loged-in-Sannce-P2-P-account.jpg
, then we now see the picture.

( In this worked example, I just have one camera connected, and so it is best to select the single screen, 1-Screen view , since no attempt is then made to cycle through different cameras, and this proves in the practice to give a more stable picture )
https://i.postimg.cc/jdwJ7S8y/1-Screen-View.jpg
3769https://i.postimg.cc/6yK3stxQ/1-Screen-View.jpg (https://postimg.cc/6yK3stxQ)

( Currently we still have our computer connected to the same router/ modem as the DVR, but that is just because of how I have organised and developed all of the explanations so far. I could now disconnect the computer from my router/modem, and go to any remote location, and then, as long as I connect my computer to the internet , ( anywhere in the world ), I should still see the same picture, because I am accessing the DVR over the internet. )

So finally we have finished the main purpose of this Blog. (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software)

We progressed by firstly obtaining a working local LAN access to the DVR. But that was not necessary. So in the next posts, we explain how to obtain a working remote P2P access of the DVR , starting at a remote location , with a fresh installation of the Guarding Vision Software. We will not concern ourselves with a working local LAN access to the DVR.

DocAElstein

02-28-2018, 12:22 AM

Page 4 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software/page4 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software/page4
Post # 31 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15917&viewfull=1#post15917 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15917&viewfull=1#post15917

https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15917#post15917

-AB- Notes in preparation for full remote Cloud P2P DVR access , Installing, Setting up and using at remote location. ( No direct Access to DVR )

These two different scenarios correspond to the two next posts,

-B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15902&viewfull=1#post15902

-C- Cloud P2P remote access if no Sannce registered account holds DVR information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15919&viewfull=1#post15919

_.______________________

Obtaining remote access to DVR over the world wide web internet
Whilst it is possible to obtain over the internet access to a DVR at a remote location after installing the Guarding Vision Software for the first time, certain things will have needed to have been done previously and certain things will need to be known.
These things will not always be explained in full detail in this and following posts. They are described in detail in the previous posts, and it is advisable to read through those previous posts in order to get a full picture and understanding of the basic use of the Sannce DVR with Guarding Vision PC client software.

The DVR must be connected to the internet, - it must be “OnLine”
This is required for both -B- and -C-

DVR Enabled and password ( Verification code ) and username ( Serial No. , SN)
Initially in the first DVR set up using a mouse and monitor, or at a later date via the settings using the mouse and monitor, in the Network settings a box labelled Enable must be checked, and underneath this is a Verification Code needs to have been set.
In addition for -C- you must know this Verification Code
https://i.postimg.cc/yNN0d4bG/Enable-and-Verification-Code.jpg
For -C-, you also need to know the 9 character serial number which is typically on a label or sticker on the underside of the DVR. Typically the first character is an upper case letter, and the other 8 characters are numbers.
The serial number and the verification code are those which I have referred to throughout my previous post explanations as a second required username and password pair. In some literature these two things are simply referred to by the serial number and verification code, or Sannce Home verification code.
These two things need to be known as they will need to be filled in at a certain stage in a window that pops up when performing a so called Adding action: https://i.postimg.cc/9z3wqWPW/Second-uesrname-password-pair.jpg
In all the working examples I have discussed so far, I used the following pair. ( The password/ verification code I chose and set myself , but the serial number I cannot chose – I noted it from the underside of the DVR that I have been using )
F53992124
Sannce2
( https://i.postimg.cc/B6VK45XP/Second-usesrname-password-pair.jpg )

Sannce Registered P2P account ( Annke Sannce Registered Vision Guarding Vision Cloud P2P App Account User Name and Password by Email Addres
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15913&viewfull=1#post15913 )
Information necessary for successful setting up of the Cloud P2P, and/ or its subsequent use, is held somewhere remotely by Sannce. It can only be held by a single account at any time.
So ether
_ (For -B- ) You need to know the username and password of such an account if it exists and it has the information. ( The information and various setting up will be done automatically when you do a necessary logging in.)
or
_ ( For -C- ) If you know that no account is holding this information, you will have to register such an account, and use that.

These two different scenarios correspond to the two next posts,

-B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15902&viewfull=1#post15902

-C- Cloud P2P remote access if no Sannce registered account holds DVR information
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15919&viewfull=1#post15919

In both the cases, I will assume that the Guarding Vision Software needs to be installed for the first time, but the installation will only be briefly explained
( full details: .exe installation File: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 ;
Installation: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15902&viewfull=1#post15902
First use : https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 )

DocAElstein

02-28-2018, 12:37 AM

-B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information

For this demonstration and explanation , my DVR is at home and is connected to the internet. My computer is away from home and connected to the internet. There is no connection through any cable or local wireless network or any other network that allows any sort of direct or indirect connection between my computer and the DVR, ( other than the world wide web internet to which they are both connected)
On the computer is no installed Guarding Vision PC Client Software.
As a result of the various work detailed in the previous posts of this blog, (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901) we have a P2P account registered at Sannce. We had used that previously to obtain successful viewing of the cameras connected to the DVR via the Cloud P2P way. At this stage I have done nothing to remove anything from that account.
The account username and password are
cloudp2pee
CloudP2P.!*

I downloaded and made a fresh install of the Guarding Vision Software.
( full details: .exe installation File: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 ;
Installation: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15902&viewfull=1#post15902
First use : https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 )
After the successful installation a Guarding Vision desktop icon appeared on my computer’s desktop.
I double click on the Guarding Vision desktop icon , and as expected, I am asked on the first opening to give a “Super User” username and a password. This password is only required for further running/ opening of the Guarding Vision, and can be anything, but for the sake of simplicity I will use the same as in all previous working examples
DocAElstein
Gaudy.!*

After logging in , ( and cancelling any offered help window) , I am left with the basic Guarding Vision PC Client Software user interface.
By default, Device Management is showing a single simple ( local ) Device, - that showing with background highlighted in brown https://i.postimg.cc/0NH658DZ/Device-for-managemant.jpg
https://i.postimg.cc/qv94b9Gz/LTE-Ser-Sszu-D-1-snip.jpg
https://i.postimg.cc/cLKdcswp/LTE-Ser-Sszu-D-1.jpg

_#_Control Panel______Device Management__ Device

_Device Type______________

_#_Device _____________

_ _#_Upgrade Server _____

__+_Add New Device Type ___

On opening this ( local LAN Type ) # Device is typically the only default + Added device. The software and technology behind this is for simple local connection. This device is no use to us, because our DVR is not connected locally – it’s not connected to the same router or modem to which our computer is: I am away from home at a remote location, which might be anywhere in the world. My DVR is still at home, and is connected to my home router/modem via a LAN RJ45 Ethernet cable.
We need a type that has the ability to do the P2P remote stuff, since we need this P2P technology to get access to our DVR across the internet ( https://www.encyclopedia.com/economics/encyclopedias-almanacs-transcripts-and-maps/peer-peer-technology-p2p )
Note also that no online device is showing: The Online Device window is designed to search for ,and show, any locally connected devices such as DVRs which we can then use via a simple local connection

So we need to add a new device type: https://i.postimg.cc/L4yydWyT/Add-New-Device.jpg
We need and so check the Cloud P2P Device , https://i.postimg.cc/PJq2pbqY/Add-New-Device.jpg
After doing this the new Device type appears available to us in Device type window, https://i.postimg.cc/jdmZ27Yn/new-device-type-appears-in-Device-Type-window.jpg , but it is not selected – ( so we are still managing the simple device type , and so the large window remains empty , https://i.postimg.cc/4yKpRWdL/Still-managing-local-devices-and-we-still-have-none.jpg )

So we select the newly added Cloud P2P Device type, https://i.postimg.cc/6q1zd77S/select-the-newly-Added-P2-P-device-type.jpg .

The act of selecting / clicking the Cloud P2P Device button in the device type window is to evoke a large Sannce cloud login window, and the first thing we must do is select the land associated with our DVR, - in my case Germany , https://i.postimg.cc/MKv9zYN8/Select-country-before-login.jpg , then login , https://i.postimg.cc/GpkMZhN8/login-after-select-country.jpg .
Hitting login evokes the Sannce Login / Register window, https://i.postimg.cc/Zqk77yfz/Sannce-Login-or-Register-window.jpg . We are only interested in the upper login half, https://i.postimg.cc/HshPMNXx/only-interested-in-upper-half-of-Sannce-Login-or-Register-window.jpg , since we are wanting to use our already registered Sannce account, cloudp2pee

cloudp2pee
Cloud2P2.!*

We add that password and username details of our already registered account, and login , https://i.postimg.cc/7Y6Wf4Cd/Add-details-of-existing-Sannce-account-and-login.jpg
We should then see some Processing … going on, https://i.postimg.cc/x8R87HGx/Some-processing-is-done.jpg , which may take a few seconds since it is attempting to access information held by Sannce. If this “Importing” is successful then we will see our device appearing in the large window which is now managing Cloud P2P devices https://i.postimg.cc/jjrcQY5s/Succesful-Import-of-cloudp2pee.jpg

We are finished now, and we should be able to access our DVR via the Main View window,
https://i.postimg.cc/NMBNYvqN/main-view-after-Succesful-Import-of-cloudp2pee.jpg
3771https://i.postimg.cc/bGV0HMvb/main-view-after-Succesful-Import-of-cloudp2pee.jpg (https://postimg.cc/bGV0HMvb)

https://i.postimg.cc/nh9SG1G1/1-camera-view-after-Succesful-Import-of-cloudp2pee.jpg https://i.postimg.cc/rmjfwZqq/1-camera-view-after-Succesful-Import-of-cloudp2pee.jpg https://i.postimg.cc/9X1km0fy/1-camera-view-after-Succesful-Import-of-cloudp2pee.jpg
3770https://i.postimg.cc/xqJ5g0Md/1-camera-view-after-Succesful-Import-of-cloudp2pee.jpg (https://postimg.cc/xqJ5g0Md)

DocAElstein

03-01-2018, 06:02 PM

-C- Cloud P2P remote access if no Sannce registered account holds DVR information
Possible Problem! Need to remove details of DVR from Sannce registered devices

For this demonstration and explanation , my DVR is at home and is connected to the internet. My computer is away from home and connected to the internet. There is no connection through any cable or local wireless network or any other network that allows any sort of direct or indirect connection between my computer and the DVR, ( other than the world wide web internet to which they are both connected)
On the computer is no installed Guarding Vision PC Client Software.

Possible Problem! Need to remove details of DVR from Sannce registered devices
As a result of the various work detailed in the previous posts of this blog, (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901) we have a P2P account registered at Sannce. We had used that previously to obtain successful viewing of the cameras connected to the DVR via the Cloud P2P way. At this stage I have done nothing to remove anything from that account.
The account username and password are
cloudp2pee
CloudP2P.!*

This gives us a problem: Many accounts may be registered and any account could Add / register the DVR to make it available at Sannce for the P2P remoter access. But, at any one time only one account may have done this Adding / registering.
( If you logged in with a valid Sannce P2P account, but tried to Add a device which another account had Added already, then you would get an error https://i.postimg.cc/65y1rbFy/Adding-Failed-Open-SDK-305001-The-device-has-been-added-by-others.jpg )
You could consider this phenomena as if the account “owned the rights” to the use of the DVR via P2P remote access. It is similar to the idea of the account having the Copyright to such use, or the sole legal right to determine such use.
We overcome the problem by using these “rights” to effectively remove that right, or in other words to give up the ownership rights.
Remove an accounts Device information.
This can be done very simply from the Guarding Vision Software through the Device Management
________Device Management
You must be logged in to the relevant account, and the act of logging in should automatically import the devices it “owns”. That is to say the devices which had been Added / in order to make the DVR available at Sannce for the P2P remoter access.

So, first , we must log in with the account on any computer anywhere that is
_ running the Guarding Vision software
and
_ the computer must be connected to the internet, ( since the information we want to remove from the account is held by Sannce at some remote place )

Then in Device Management , we select the actual device and then hit the Delete button
https://i.postimg.cc/h45qRmBQ/Delete-an-Add-ed-device-using-the-Sannce-account-that-Add-ed-it.jpg
https://i.postimg.cc/sxqFYkc4/Delete-an-Add-ed-device-using-the-Sannce-account-that-Add-ed-it.jpg
If the deleting was successful then afterwards you will no longer see the entry in the Device Management window
https ://i.postimg.cc/j2L0Jxzj/Deleted-an-Add-ed-device-using-the-Sannce-account-that-Add-ed-it.jpg

( If that account had only stored the details of that one DVR, then we would be warned on logging in on any other occasion that the account had no “resources” https://i.postimg.cc/xCsVCJN7/After-Add-ed-Delete-any-log-in-does-not-import-and-tells-you-why-There-is-no-resource-to-be-impo.jpg )

We can now proceed with the main part of this final blog section, Cloud P2P remote access if no Sannce registered account holds DVR information.

_.... see next post

DocAElstein

03-01-2018, 09:54 PM

Cloud P2P remote access if no Sannce registered account holds DVR information.

Prepare Sannce account registering details.
As discussed in detail here, https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15911&viewfull=1#post15911 , it is wise to have prepared before hand all the details for Sannce P2P account registration.
For the purposes of this demonstration I have prepared a username and password to use, as well as registering a new gmail Email account.
User Name cloudpooh
Password CloudP2P.!*
Confirm Password CloudP2P.!*
Email Address poohessin@gmail.com

I have this information stored at a convenient place so that I can access it quickly when needed, for example in a text file, https://i.postimg.cc/90H2s4Kq/Annke-Sannke-P2-P-Registration-details-prepared-in-text-file.jpg
Also in this way, -C- , we also need the username/password information which we discussed as coming from the actual DVR serial number, and a Verification Code set via the monitor and mouse in order to “Enable” the DVR for such internet things. These are the values used throughout my previous posts,
F53992124
Sannce2
I keep this data also convenient to hand during the following work, https://i.postimg.cc/xdRzP4jW/Serial-Number-and-Verification-Code-handy-in-test-file.jpg
Any previous version of the Guarding Vision software I have de installed for the purposes of the following demonstration and explanations

I downloaded and made a fresh install of the Guarding Vision Software.
( full details: .exe installation File: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 ;
Installation: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15902&viewfull=1#post15902
First use : https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15901&viewfull=1#post15901 )
After the successful installation a Guarding Vision desktop icon appeared on my computer’s desktop.
I double click on the Guarding Vision desktop icon , and as expected, I am asked on the first opening to give a “Super User” username and a password. This password is only required for further running/ opening of the Guarding Vision, and can be anything, but for the sake of simplicity I will use the same as in all previous working examples
DocAElstein
Gaudy.!*

After logging in , ( and cancelling any offered help window) , I am left with the basic Guarding Vision PC Client Software user interface.
By default, Device Management is showing a single simple ( local ) Device, - that showing with background highlighted in brown https://i.postimg.cc/0NH658DZ/Device-for-managemant.jpg
https://i.postimg.cc/qv94b9Gz/LTE-Ser-Sszu-D-1-snip.jpg
https://i.postimg.cc/cLKdcswp/LTE-Ser-Sszu-D-1.jpg

_#_Control Panel______Device Management__ Device

_Device Type______________

_#_Device _____________

_ _#_Upgrade Server _____

__+_Add New Device Type ___

On opening the Gaurding Vision Software for the first time, this ( local LAN Type ) # Device is typically the only default + Added device. The software and technology behind this is for simple local connection. This device is no use to us, because our DVR is not connected locally – it’s not connected to the same router or modem to which our computer is: I am away from home at a remote location, which might be anywhere in the world. My DVR is still at home, and is connected to my home router/modem via a LAN RJ45 Ethernet cable.
We need a type that has the ability to do the P2P remote stuff, since we need this P2P technology to get access to our DVR across the internet ( https://www.encyclopedia.com/economics/encyclopedias-almanacs-transcripts-and-maps/peer-peer-technology-p2p )
Note also that no online device is showing: The Online Device window is designed to search for ,and show, any locally connected devices such as DVRs which we can then use via a simple local connection

So we need to add a new device type: https://i.postimg.cc/L4yydWyT/Add-New-Device.jpg
We need and so check the Cloud P2P Device , https://i.postimg.cc/PJq2pbqY/Add-New-Device.jpg
After doing this the new Device type appears available to us in Device type window, https://i.postimg.cc/jdmZ27Yn/new-device-type-appears-in-Device-Type-window.jpg , but it is not selected – ( so we are still managing the simple device type , and so the large window remains empty , https://i.postimg.cc/4yKpRWdL/Still-managing-local-devices-and-we-still-have-none.jpg )

So we select the newly added Cloud P2P Device type, https://i.postimg.cc/6q1zd77S/select-the-newly-Added-P2-P-device-type.jpg .

The act of selecting / clicking the Cloud P2P Device button in the device type window is to evoke a large Sannce cloud login window, and the first thing we must do is select the land associated with our DVR, - in my case Germany , https://i.postimg.cc/MKv9zYN8/Select-country-before-login.jpg , then login , https://i.postimg.cc/GpkMZhN8/login-after-select-country.jpg .
Hitting login evokes the Sannce Login / Register window, https://i.postimg.cc/Zqk77yfz/Sannce-Login-or-Register-window.jpg .
In this post, we need to register an account for the first time, so are initially only interested in the lower half of that Sannce Login / Register window, https://i.postimg.cc/Bbt73Fwn/Lower-Register-Half-of-Sannke-Annke-P2-P-account-register-ng-account.jpg

So we hit Register, https://i.postimg.cc/85pny9RW/Register-Sannke-Annke-P2-P-account-register-ng-account.jpg ,

At this point we should prepare to try and do the registering quickly to improve the chances of success. We should get out details handy to copy from, and it is also a good idea to get Email account that you use open and ready to receive a security verification code that will be sent as part of the registering process.
So we fill in quickly and hit the Send button, https://i.postimg.cc/ydh3Nptf/Add-registration-detals-and-hit-Send-Message-button.jpg , which should send a security verification code to the given Email address.
Typically the code arrives very quickly at an Email address, and so be prepared for a message of some form in your in box https://i.postimg.cc/SRWB3CXY/code-arrived-at-EMail-address.jpg https://i.postimg.cc/h4TRXWC4/code-arrived-at-EMail-address.jpg https://i.postimg.cc/zXNZWtMC/code-arrived-at-EMail-address.jpg
The code should be typed in quickly and then hit the Register button quickly https://i.postimg.cc/nzfQpfRj/Wnter-code-and-register-quickly.jpg
A window should appear for a split second saying something like Registration Complete , after which you are returned to the Login/ Registration window, from which you can now use the new account to log in. We are only interested now in the top half of the login/ Register window and we ignore the Register button. We simply fill in our newly made account username and password, and hit the Login button , https://postimg.cc/gallery/JDLXJFT .
Because we have no information in this new account we will be told that there is no resource to be imported in a small black window bottom right, https://i.postimg.cc/Yq7jZ6np/logged-in-and-no-resource-to-be-imported.jpg .

Because we have no Online Device showing in the Online Device Window, https://i.postimg.cc/85bgcLHd/No-Online-device.jpg , we are restricted to using the + Add Device in the large Device Management Window, https://i.postimg.cc/QtcxbBqV/Restricted-to-Add-Device-in-the-large-Device-management-window.jpg
You then need to add in the two Fields,
https://i.postimg.cc/ry37wgXk/Fill-in-Serial-Number-and-Verification-Code.jpg https://i.postimg.cc/xdRzP4jW/Serial-Number-and-Verification-Code-handy-in-test-file.jpg
, and then hit OK, https://i.postimg.cc/c432gY08/Fill-in-Serial-Number-and-Verification-Code-then-OK.jpg
Some processing may take a few seconds, https://i.postimg.cc/Rhk1xNDk/Processing-can-take-a-while.jpg , since its calling up information held somewhere by Sannce.
Usually this will then work as intended, and our device appears, https://i.postimg.cc/NG5WtSnD/Success-Device-appears.jpg .
It appears to have been a success, but if we go now in to the Main Viewing we don’t seem to see any picture, and note also that although we do see the new Folder for the account cloudpoohpee , there is no + alongside it, so there are no resources, that is to say, no items in any drop down list. This ties up with the previous small black window bottom , https://i.postimg.cc/Yq7jZ6np/logged-in-and-no-resource-to-be-imported.jpg , which popped up during the very first successful ,.og in with theis account.
But we have done correctly and fully and successfully all we can and all we need to do get the remote cloud P2P way working, So what’s the problem……....._

See next post....

DocAElstein

03-18-2018, 04:01 PM

_... continued from last post

It would appear that a registered P2P account with Sannce, ( in our worked example the newly made account with the user name of cloudpoohpee ) , exists to hold information for, and to act as a form of authorisation to, access one or more DVRs remotely over the internet .
We have successfully Added this information to the account, after the first log in, ( https://i.postimg.cc/c432gY08/Fill-in-Serial-Number-and-Verification-Code-then-OK.jpg )
Necessarily this registered P2P account with Sannce also needs to be able to collect the necessary details of the DVR which are required to allow the P2P access. This does not appear to occur at the same time as the information is Added to the count. That is perhaps a bit strange and not as expected, but maybe there is some technical reason for that. Also, so far, I have not seen a “button” or any other way to evoke the “bringing in” , or “setting up with” or “using” of this information in such a way that things start working as we want them to , or as they need to in order to get the functioning P2P remote internet access.
This is a dilemma. My guess is that not just me, but the entire technical people at Sannce have been in this dilemma, and never consciously got out of it. I will further guess, that like me, anyone that ever got this functioning P2P remote internet access had spent many frustrating hours trying, and then at some point, a random combination of events resulted in it working.
However , we have done correctly and fully and successfully all we can and all we need to do get the remote cloud P2P way working
This is a dilemma. But I figured out that the necessary action which we are missing is referred to as something like “importing”. The software appears to have been written to carry out this importing when a valid account is logged in. Currently we are at the situation where the account with user name cloudpoohpee holds information for, and has authorisation to, access our DVR remotely over the internet. )
All we need to do is log in with the account. But we can’t, as we are already are logged in!
So, the final action needed is Log out , and then re log in

So , first we logout from the Device Management window, https://i.postimg.cc/yYQbJPSj/logout-from-Device-Managemant-window.jpg
Because we have the Cloud P2P Device selected, we are returned to the large Sannce P2P cloud login window. We then check that we are in Germany , https://i.postimg.cc/66hSKwWD/Check-we-are-in-Germany-then-re-Login.jpg , and then re Login https://i.postimg.cc/nccWc5MM/then-re-Login.jpg . ( Typically the last username used would be remembered and written in already)
Note that we are only interested in logging in, - the registration no longer concerns us, so we ignore the Register button, https://i.postimg.cc/QMdTPQMB/Log-in-using-top-half-of-window.jpg .
After entering our current account name and password, and hitting the Login , some processing appears to be happening and if all goes well then a small black window pops up for a second to inform that “Importing succeeded![/FONT ]” https://i.postimg.cc/kG401ZVt/Importing-succeeded-bottomright-smallblack-window.jpg
https://i.postimg.cc/7hXQn1tx/Importing-succeded.jpg

Now, in [FONT=Courier New]Device Management we see the same as we did just before logging out, https://i.postimg.cc/Ss6PJbWY/Device-Management-as-before-logout-login.jpg

But the first thing we notice new in Main View is that we now have a + appearing to the left of the folder corresponding to the P2P account name , cloudpoohpee and either immediately or after a few seconds we get a working picture.
( Sometimes the receiver may “ hang” during a camera cycling process – We can “wake up” the receiver by either hitting the small restart/refresh symbol, https://i.postimg.cc/L5mbPQTC/A-refresh-can-sometimes-help.jpg , or alternatively, select the + to expand the drop down camera list, then double click on the first camera, https://i.postimg.cc/dVgN6V6T/click-on-then-double-click-first-camera.jpg

For a single camera, viewing in 1-Screen view, https://i.postimg.cc/52Xk8CBV/1-Screen-view.jpg , may give slightly more stable results, but it seems that in the Cloud P2P viewing, a click on the recycle/refresh symbol is still needed occasionally to “wake up” the DVR, https://i.postimg.cc/LXK798ZM/1-Screen-viewclick-on-the-restart-refresh-often-good.jpg . There may be some settings to influence recycling and updating, as there are certainly many more features to be tried with the Guarding Vision Software , but for now, that concludes the main purpose of this Blog. (https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software)

3774https://i.postimg.cc/Y4R88k3X/1-Screen-viewclick-on-the-restart-refresh-often-good.jpg (https://postimg.cc/Y4R88k3X)

DocAElstein

03-20-2018, 04:09 PM

__________________________________

DocAElstein

03-22-2018, 01:29 PM

________________________

DocAElstein

03-23-2018, 12:48 PM

__________________________

DocAElstein

03-24-2018, 02:17 PM

__________________________________

DocAElstein

03-24-2018, 02:49 PM

____________________________________

DocAElstein

03-28-2018, 12:48 AM

hkjahhdahdhdh

DocAElstein

03-28-2018, 01:36 PM

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

03-29-2018, 04:13 PM

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

04-02-2018, 02:00 PM

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

04-02-2018, 02:01 PM

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

04-02-2018, 02:26 PM

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

04-02-2018, 03:16 PM

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

04-02-2018, 05:28 PM

Using Excel 2007 32 bit

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.2018RT1RT2RT3RT402.04.201802.Apr.2018Raghu

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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.2018MT1MT2MT3MT402.Apr.201802.Apr.2018Marga ret

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

04-02-2018, 05:44 PM

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

DocAElstein

04-02-2018, 05:47 PM

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

04-02-2018, 05:55 PM

This is post #51 in Thread.
Links
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15937&viewfull=1#post15937
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15937&viewfull=1#post15937
https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software/page6#post15937 https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software/page6#post15937

These are shortened summarised notes of specific worked examples. Missing information can be found in full detail in the main previous notes.

Example of 2b) -B- Cloud P2P remote access if you know the password and username of Sannce registered account holding DVR P2P relevant information
Main Thread notes: https://excelfox.com/forum/showthread.php/2769-P2P-Cloud-DVR-remote-Access-via-a-(remote)-PC-Using-Guarding-Vision-PC-Client-Software?p=15918&viewfull=1#post15918

A fairly new standard Windows 10 PC
I installed the software, Gaurding Vision, from a personal stored .exe file
An icon appeared as expected. https://i.postimg.cc/V6mq3PGg/Icon-appeared-as-expected.jpg - I double clicked on it, which brought me the usual warning asking me if I wanted to let the program do what it wanted to do. I clicked yes
By the first launch I get a window to Register Administrator [/FONT ]. https://i.postimg.cc/N018Jj4L/Register-administrator-on-first-software-run.jpg I can use any name and password which must not be, ( but can be ), that used on any other computer. It is only used to get access to the software client on this particular computer. For convenience and ease of remembering, I use the same name and password that I have been using throughout all tutorial work. Furthermore, I check the box to [FONT=Courier New]Enable Auto.login, just for convenience,
https://i.postimg.cc/VNyBWCX3/Register-administrator.jpg
DocAElstein
Gaudy.!*
Note that both the username and password are case sensitive.
I get offered a help wizard in first use. So far I have always ignored this, https://i.postimg.cc/T35Jb95V/Ignore-Help-wizzard.jpg and close it

A couple of things we note on this fist GUI view, is
_ We just two Main Tabs, Control Panel and Device Management https://i.postimg.cc/PrRMNcJf/First-GUI-view.jpg
¬ _ We are currently looking at Device Management, and by default a Device has been added. It goes by the name of simply Device , which is a bit misleading, as really this is indicating the simple local LAN type device ( our way (ii) in previous discussions ). We should think more logically that we have just the options , Upgrade Server and + Add New Device type: Effectively on opening the software has automatically clicked on + Add New Device type and made a device type of the simple way (ii) LAN local PC access

We want a P2P device type, so we
_ click on + Add New Device type , and select a Cloud P2P device https://i.postimg.cc/Hsx2YHpP/Add-New-Device-Type-Cloud-P2-P-Device.jpg
https://i.postimg.cc/8kw4gsV6/Cloud-P2-P-Device-OK.jpg
Which causes the device type to appear, https://i.postimg.cc/kGjvQYyc/Cloud-P2-P-Device-type-appears.jpg but its not actually selected, ( we are still looking at any locally connected Devices ). So we click on the Cloud P2P Device
https://i.postimg.cc/L54VZFj5/click-on-the-Cloud-P2-P-Device-in-Device-Type-window.jpg
in the Device Type left window. Now the Cloud P2P Device in the Device Type left window becomes highlighted and some processing is done,
https://i.postimg.cc/Kz2fxMzn/clicked-on-the-Cloud-P2-P-Device-in-Device-Type-window.jpg
https://i.postimg.cc/htXprn67/Processing-is-done.jpg
after which we are prompted to login. Important at this point is to select first the land in which our DVR is, https://i.postimg.cc/3wp1sBK8/Prompted-to-login-remember-land.jpg , after which select Login
https://i.postimg.cc/WzSX91s0/Login.jpg
To now login, we need to know the password and username of Sannce registered account holding DVR P2P relevant information. So we add this information and then hit login. ( The username is not case sensitive, but the password is )
Some processing is done https://i.postimg.cc/htXprn67/Processing-is-done.jpg , and if successful, a small black window bottom right appears to indicate the success, and the Device Name and Serial No. of our DVR appears
https://i.postimg.cc/Y9z39CGT/Importing-succeeded.jpg ,

At this stage we are in Device Management but have finished managing the device.
So now we hit the View tab at the top, https://i.postimg.cc/wBs46zkd/View-Main-View.jpg
( and thereafter we will have a large View Tab added )
https://i.postimg.cc/4xyFSV7y/Main-View.jpg

We are finished at this point.

I am not too clear on what all the various view setting mean, but usually some random clicking around on the various View and Camera options will bring the thing into life. In particular, clicking refresh symbols seems to help get things going.
https://i.postimg.cc/nVK5jHfF/Refresh-Symbol.jpg , https://i.postimg.cc/15JjBJzb/Refresh-Symbol.jpg , https://i.postimg.cc/3JKq2P3g/Refresh-Symbol.jpg

DocAElstein

04-02-2018, 06:15 PM

lslfhlkshfhkhlkahfalhf

DocAElstein

04-02-2018, 06:26 PM

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

04-02-2018, 06:31 PM

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

DocAElstein

04-02-2018, 06:44 PM

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

04-02-2018, 06:55 PM

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

04-02-2018, 06:57 PM

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

04-02-2018, 07:01 PM

Data files after final (second) consolidation:

Using Excel 2007 32 bit

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.201802.Apr.2018Greg

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

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

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

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

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

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

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

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

14
49ABC49
333.45 €
99
33,011.55 €02.Apr.2018RT1RT2RT3RT4
02. Apr 1802.Apr.2018Raghu

15
50ABC50
11.99 €
1
11.99 €02.Apr.2018Raghu

16
Worksheet: Tabelle1

Using Excel 2007 32 bit

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.201802.Apr.2018Marga ret

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

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

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

48ABC48
3.99 €
35
139.65 €02.Apr.2018Margaret
Worksheet: Tabelle1

Using Excel 2007 32 bit

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

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

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

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

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

DocAElstein

04-02-2018, 07:17 PM

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

04-07-2018, 12:43 AM

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

05-13-2018, 02:28 PM

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

05-13-2018, 02:31 PM

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

05-13-2018, 02:32 PM

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

05-13-2018, 02:40 PM

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

DocAElstein

05-24-2018, 01:24 PM

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

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

06-02-2018, 11:30 AM

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 = "" & _
"Dear Team, " & _
"Please open the file from below link and change the date on the respective cell after you completed your task. " & _
fileName & ".xlsm" & " is created. " & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & Path & fileName & ".xlsm" & _
""">Files are saved here</A>" & "-->" & Range("A1").Value & _
" Best Regards," & _
" "

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 = "" & _
"Hi Team, " & _
"Please open the file from below link and put your signature on the respective cell after you completed your task. " & _
ActiveWorkbook.Name & " is created. " & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & """>Link to the file</A>" & _
" Regards," & _
" Thai Nguyen "
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

06-22-2018, 10:34 AM

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

06-30-2018, 02:36 PM

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

Codes for Alf and sandy666

Option Explicit
Sub SendfromExcelVBAExpgmail()
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") = "ExcelVBAExp@gmail.com" '
.Configuration(LCD_CW & "sendpassword") = "xxxxxxxxxxxxxx" ' '
' .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 = "" & _
"This is sent from EMail account:" & _
" Username: ""ExcelVBAExp@gmail.com""" & _
" Password: ""xxxxxxxxxxxxxxxxxxxxxx""" & _
" " & _
" Please click on the 5 links below and tell me what happens, thanks!" & _
" 1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
" 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>" & _
" 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>" & _
" 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>" & _
" 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 "xxxxxxxxxxxxxx"
.CC "xxxxxxxxxxxxxa"

.BCC = ""
.from = """ExcelVBAExp@gmail.com"" <ExcelVBAExp@gmail.com>"
.Subject = "Sent from EMail address: ExcelVBAExp@gmail.com"
.htmlbody = strHTML

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

Sub SendfromFahrradprinzessinunterwegsgmail()
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") = "Fahrradprinzessinunterwegs@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 = "" & _
"This is sent from EMail account:" & _
" Username: ""Fahrradprinzessinunterwegs@gmail.com""" & _
" Password: ""xxxxxxxxxxxxxxxxxxx""" & _
" " & _
" Please click on the 5 links below and tell me what happens, thanks!" & _
" 1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
" 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>" & _
" 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>" & _
" 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>" & _
" 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 "xxxxxxxxxxxxxxxxxxxx"
.CC "xxxxxxxxxxxxxxxxxxx"
.BCC = ""
.from = """Fahrradprinzessinunterwegs@gmail.com"" <Fahrradprinzessinunterwegs@gmail.com>"
.Subject = "Sent from EMail address: Fahrradprinzessinunterwegs@gmail.com"
.htmlbody = strHTML

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

Sub SendfromDocAlnsteinGermanTelekom()
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") = "securesmtp.t-online.de" ' "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") = "Doc.Alnstein@t-online.de" '
.Configuration(LCD_CW & "sendpassword") = "xxxxxxxxx" ' '
' .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 = "" & _
"This is sent from EMail account:" & _
" Username: ""Doc.Alnstein@t-online.de""" & _
" Password: ""xxxxxxxxxxx""" & _
" " & _
" Please click on the 5 links below and tell me what happens, thanks!" & _
" 1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
" 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>" & _
" 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>" & _
" 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>" & _
" 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 "xxxxxxxxxxxxxxxxxxxxxxxx"
.CC "xxxxxxxxxxxxxxxxxxxxxxxxx"

.BCC = ""
.from = """Doc.Alnstein@t-online.de"" <Doc.Alnstein@t-online.de>"
.Subject = "Sent from EMail address: Doc.Alnstein@t-online.de"
.htmlbody = strHTML

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

Instructions:
Three files are attached. Please download them and store them all somewhere on your computer. They can be stored anywhere, but important is that they are all stored in the same Folder :
All 3 files stored in same place.JPG : https://imgur.com/rFu0TML

Please open only one file “Test File xxxx to send EMail containing Hyperlinks to Files.xlsm”
Enable macros.

There are three codes in file “Test File xxxx to send EMail containing Hyperlinks to Files.xlsm”.
The codes are very similar, differing only in the Email account used as the .Sender:
Sub SendfromDocAlnsteinGermanTelekom()
Sub SendfromFahrradprinzessinunterwegsgmail()
Sub SendfromExcelVBAExpgmail()

Please try to run those codes.
Each code should send you an Email which on arrival will look something similar to this:
Typical received EMail.JPG : https://imgur.com/4oNXNtW

Please click on the 5 Hyperlinks and tell me what happens.

My final goal is to get a Hyperlink which when clicked opens an Excel or Word File.
I have tested the codes sending to my gmail and German Telekom Email accounts.
But so far, only link 1 works. But link 1 does not open a file: It simply sends you to a file sharing site. So link 1 is a temporary solution for me.

Code for Thai in next post....

DocAElstein

07-01-2018, 02:17 PM

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 = "" & _
"This is sent from EMail account:" & _
" Username: ""excellearning12@gmail.com""" & _
" Password: ""xxxxxxxxxxxxx""" & _
" " & _
" Please click on the 5 links below and tell me what happens, thanks!" & _
" 1 <A HREF=""https://app.box.com/s/x01liz3ralbdrt152i52fpwb0wx40ff3"">link to box net cloud free file sharing</A>" & _
" 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>" & _
" 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>" & _
" 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>" & _
" 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

07-07-2018, 01:37 PM

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

DocAElstein

07-19-2018, 02:24 PM

Test runs from code
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

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

Using Excel 2007 32 bit

Sheet1Sheet1Test OutputTest OutputSheet2Sheet2

Customer Assembly Customer Assembly

Nu Torque
13456Nu Torque
13456

Blu OriginSpaceshipBlu OriginSpaceship

Jet Blue21ABC

Alaska
789

ToyotaSupra

EmirateABC12345

Jet Blue21ABC

Alaska
789

ToyotaSupra

EmirateABC12345

Dup 2 of ToyotaDup 2 of SupraToyotaSupra

Dup 2 of EmirateDup 2 of ABC12345EmirateABC12345

Spaceship12Spaceship
12
Worksheet: Tabelle3

Using Excel 2007 32 bit

Sheet1Sheet1Test OutputTest OutputSheet2Sheet2

Customer Assembly Customer Assembly

Nu Torque
13456Nu Torque
13456

Blu OriginSpaceshipAlaska
789

Jet Blue21ABCExcel123HiThaiExcel123HiThai

Alaska
789Blu OriginSpaceship

ToyotaSupraEmirateABC12345

EmirateABC12345Jet Blue21ABC

ToyotaSupra
Worksheet: Tabelle3

DocAElstein

07-19-2018, 02:40 PM

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

07-23-2018, 03:57 PM

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

DocAElstein

07-23-2018, 04:03 PM

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

DocAElstein

07-26-2018, 02:33 PM

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

07-26-2018, 02:43 PM

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

DocAElstein

07-29-2018, 11:51 AM

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

DocAElstein

07-29-2018, 12:00 PM

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 )

DocAElstein

07-29-2018, 01:31 PM

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

07-29-2018, 01:33 PM

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

DocAElstein

07-30-2018, 12:38 PM

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

07-30-2018, 12:43 PM

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

07-31-2018, 12:54 PM

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

DocAElstein

08-02-2018, 11:57 AM

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
Or
_1_(i) _b) Scroll down and select manage attachments
a)PaperClipIcon or b)ManageAttachmants.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
2103

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

08-02-2018, 12:18 PM

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

11-04-2018, 06:43 PM

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

11-11-2018, 03:47 PM

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

DocAElstein

11-18-2018, 06:03 PM

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:

Sub FoxySingleCellNamedRanges()
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 Dim WkBk As Workbook
260 For Each WkBk In Workbooks
270 Call FukYaWkBkNames(WkBk)
280 'Call GeTchaNms(280, WkBk)
290 Next WkBk
300 Workbooks("Data1.xls").Close savechanges:=True
310 Workbooks("Data2.xlsx").Close savechanges:=True
312 '0b) clear the entire data ranges in the first worksheet in the main workbook, both headers and data
315 ThisWorkbook.Worksheets.Item(1).Range("B5:C12").ClearContents
320 Rem _1) Data1 "Food" header
330 '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
340 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
350 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
360 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
370 Call GeTchaNms(370, dataWb1xls)
380 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
390 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "Data1.xls'!Dta1Foodheader" ' "Going" to Workbook Data1.xls
400 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "[Data1.xls]Tabelle4'!Dta1Foodheader" ' "Going" to any worksheet in Data1.xls
410 '1b) Data1 cell Worksheet Scoped to one of its worksheets: Info needed is held in the named objects object of its second worksheets
420 Rem _1 Add some named ranges
430 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
440 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
450 dataWb1xls.Worksheets.Item(2).Names.Add Name:="Ws2Dta1Foodheader", RefersTo:=Application.Range(Dat1Tab1B5)
460 Call GeTchaNms(460, dataWb1xls)
470 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
480 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "[Data1.xls]Tabelle2'!Ws2Dta1Foodheader"
490 '1b)(ii)
500 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
510 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
520 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "[Data1.xls]Tabelle2'!Ws2Dta1Foodheader"
530 dataWb1xls.Close savechanges:=False ' I made no changes intentionally , so save without changes in case I accidentally changed anything
540 '1c) Data1 cell Workbook Scoped to a different (open) workbook : Info needed for a range in the data 1 file is held in the workbooks name objects collection object of that workbook, the main file in this case
550 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
560 Set dataWb1xls = Workbooks("Data1.xls") ' We need this open for the referred to range in the RefersTo:= range reference below
570 WbMain.Names.Add Name:="MainDta1Foodheader", RefersTo:=Application.Range(Dat1Tab1B5)
580 dataWb1xls.Close savechanges:=False ' I had this open for the Refers To:= above, but I did not change anything, for example, this time i was not doing anything to any of its named range objects, so just iin case I accidentally changed anything I will close without saving any changes
590 Call GeTchaNms(590, WbMain)
600 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "MasturFile.xlsm'!MainDta1Foodheader" ' "Going" to Workbook MasturFile.xlsm
610 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "[MasturFile.xlsm]Tabelle4'!MainDta1Foodheader" ' "Going" to any worksheet in MasturFile.xlsm
620 '1d) This is an attempt to get at the named range object in a roundabout sort of a way. Here the data 1 cell s scoped to the second data file, "Data2.xlsx" ( Workbooks scoped to workbook "Data2.xlsx" )
630 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data1.xls"
640 Set dataWb1xls = Workbooks("Data1.xls")
650 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
660 Set dataWb2xlsx = Workbooks("Data2.xlsx")
670 dataWb2xlsx.Names.Add Name:="Dta2Dta1Foodheader", RefersTo:=Application.Range(Dat1Tab1B5)
680 Let Application.Range(MBkTab1B5).Value = LisWkBkPath & "Data2.xlsx'!Dta2Dta1Foodheader" ' "Going" to Workbook MasturFile.xlsm
690 dataWb1xls.Close savechanges:=False ' I had this open for the Refers To:= above, but I did not change anything, for example, this time i was not doing anything to any of its named range objects, so just iin case I accidentally changed anything I will close without saving any changes
700 dataWb2xlsx.Close savechanges:=True ' A name object was Added, so I have a change to save
710 Let Application.Range(MBkTab1B5).Value = Application.Range(MBkTab1B5).Value ' I have done this here to "catch" the value put in, as it seems to vanish if I re enter the formula ??
720 Rem 2 Experiments with named ranges in the LHS , like in Range("rngNamed") =
730 '2a) scope to a data file
740 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
750 Set dataWb2xlsx = Workbooks("Data2.xlsx") ' Open an arbritrary data file to use one if its names objects as the place to go to get the info about the named range
760 dataWb2xlsx.Names.Add Name:="Dta2MainFoodheader", RefersTo:=Application.Range(MBkTab1B5)
770 Call GeTchaNms(770, dataWb2xlsx)
780 Let Application.Range(LisWkBkPath & "Data2.xlsx'!Dta2MainFoodheader").Value = LisWkBkPath & "Data1.xls'!Dta1Foodheader" ' LHS is going to workbook Data2.xlsx RHS is "Going" to Workbook Data1.xls
790 dataWb2xlsx.Close savechanges:=True ' A name object was Added, so I have a change to save
800 Let Application.Range(LisWkBkPath & "Data2.xlsx'!Dta2MainFoodheader").Value = LisWkBkPath & "Data1.xls'!Dta1Foodheader" ' LHS is going to workbook Data2.xlsx RHS is "Going" to Workbook Data1.xls
810 '2b) Workbooks Scope to main workbook: Info for named range is in Name Objects collection of Main workbook
820 WbMain.Names.Add Name:="MainFoodheader", RefersTo:=Application.Range(MBkTab1B5)
830 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
840 Call GeTchaNms(840, WbMain)
850 Rem 3 Bring in Header "Suppliment" from data 2 workbook directly without named ranges
860 Workbooks.Open Filename:=ThisWorkbook.Path & "\Data2.xlsx"
870 Set dataWb2xlsx = Workbooks("Data2.xlsx") ' Needed for next line
880 Let Application.Range("=" & "'" & WbMain.Path & "\" & "[" & WbMain.Name & "]" & WbMain.Worksheets.Item(1).Name & "'" & "!" & "B10").Value = "=" & "'" & dataWb2xlsx.Path & "\" & "[" & dataWb2xlsx.Name & "]" & dataWb2xlsx.Worksheets.Item(1).Name & "'" & "!" & "B10"
890 dataWb2xlsx.Close savechanges:=False
End Sub

DocAElstein

11-18-2018, 06:06 PM

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

11-18-2018, 06:08 PM

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

DocAElstein

11-18-2018, 06:21 PM

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

DocAElstein

11-20-2018, 06:12 PM

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

11-20-2018, 09:44 PM

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

11-21-2018, 02:02 AM

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

11-21-2018, 06:13 PM

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

12-06-2018, 10:13 PM

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

12-09-2018, 08:40 PM

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

12-09-2018, 08:42 PM

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

12-24-2018, 01:10 PM

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

12-24-2018, 01:12 PM

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

12-24-2018, 01:16 PM

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

12-30-2018, 08:47 PM

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

12-31-2018, 12:43 AM

'

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

01-01-2019, 07:41 PM

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

01-01-2019, 07:49 PM

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
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=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (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=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=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
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=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg)
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/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

DocAElstein

01-01-2019, 07:51 PM

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

01-09-2019, 09:11 PM

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

The coding is split into 2 parts to fil it into a Forum Post. But this and the coding in the next post form a single routine. That forms the main routine. In addition, a routine Called by the Main routine is required, Public Sub GetElemsText( ) , which is posted in the over next post.

Option Explicit
Sub EP() ' http://www.excelforum.com/showthread.php?t=1148621&page=7&p=4452110&highlight=#post4452110
Rem 1)File Info
'Dim wsLkUp As Worksheet: Set wsLkUp = ThisWorkbook.Worksheets("Tabelle1"): wsLkUp.Activate
Dim strURL As String ' File with Page ' file:///G:/Excel0202015Jan2016/OffenFragensForums/eileenslounge/XP/Updates/report.html
Let strURL = ThisWorkbook.Path & "\Updates\" & "report.html" ' '"http://www.ernaehrung.de/lebensmittel/de/W233000/Fleischkaese.php" ' "http://www.ernaehrung.de/lebensmittel/de/W233000/PloppyPooFukYou"
' Application.Wait Now + TimeValue("00:00:02") '
Rem 2) '
'2a xmlHTTP stuff MSXML2.XMLHTTP.6.0 IXMLHTTPRequest Alan: "simple xml request here, so you could give URL a simple File of the HTML code" 'Dim Request As Object: Set Request = CreateObject("MSXML2.XMLHTTP") 'Late Inding https://msdn.microsoft.com/en-us/library/ms759148(v=vs.85).aspx
Dim request As MSXML2.XMLHTTP: Set request = New MSXML2.XMLHTTP 'Early Binding Requires --- TOOLS --- REFERENCES -- tick Microsoft XML, v6.0 http://www.mrexcel.com/forum/excel-questions/759592-help-createobject-msxml2-xmlhttp-macro.html
'Application.Cursor = xlWait'cursor disable..just to be on the safe side???
With request '(or With CreateObject("msxml2.xmlhttp"))'By virtue of GET this is a simplified "xml" request
.Open bstrmethod:="GET", bstrURL:=strURL, varasync:=True ' ("GET", strURL, True) 'just preparing the request type, how and what type. The second argument determines type. This may then require further info in next lines Only diferrence to pike's and Kyle's opening and sending stuff is argument:- Leith: "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. I prefer to use asynchronous mode and test if my timeout period has expired to prevent the code from hanging due to an unresponsive server. In the example I provided I used synchronous mode to reduce the amount the code and keep it easier to understand."
'No extra info here for type GET ' ' '.setRequestHeader "DNT", "1"
'.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' Content-Type is the property name, x-www-form-urlencoded is the value (content type in the html is "text/html" not "x-www-form-urlencoded" - that is something diifferent) You can have different request header properties and pass different values. This isn't unusual, just not required in this case When you POST data to a server, you need to tell it what format you are sending it in. So the Type of Content sent in the body of the request (the send bit) is application/x-www-form-urlencoded
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
.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
Set request = Nothing ' This section is finished. We no longer need the Library. Optionally can therefore Set request = Nothing, a step most appropriate if required for some reason. Previous arguments of good practice to prevent memory leaks and data corruption appear outdated in favour of only using when a good reason is apparent to avoid masking when it is a good idea.
'_..EP2ab Explicit Pedantry. We intend using PagrSrc through a method to produce a model Object Orientated stylio for later use through use of its Methods and Properties. This model is frequently referred to as a Document Orientated Model, DOM. Some steps in this creation of the "DOM" can frequently be confused with the processes in '2a which are in fact now finished. Part of the .Send , "finishes all processes. We move on to '2b. Only PagrSrc is required to be "taken over" as it were
'2b DOM stuff' Make OOP type model of HTML code, using Microsoft HTML Office Library
'Dim HTMLdoc As HTMLDocument: Set HTMLdoc = New HTMLDocument 'Early binding - will not work with .Write:- Leith "This is a case where late binding has to be used. The htmlfile is an ActiveX object that is a wrapper function for the IHTMLDocument2 interface in MSXML2. This gets into a lot of low level system operation......." https://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-vba-2.html#post4031122 https://www.excelforum.com/excel-programming-vba-macros/1214789-late-binding-2.html#post4820307 'Early binding TOOLS >>> REFERENCES >>Microsoft HTML Object Library
Dim HTMLdoc As Object: Set HTMLdoc = CreateObject("htmlfile") 'Late Binding, ' Create an empty HTML Document.
HTMLdoc.Open 'EP2b(i) This clears the values in the HTMLdoc. Complete Explicit Pedantry. in usage outside VBA, Methods for an instance will often be required which require a clearing of an instance before "using". Approximately in VBA this can be considered putting the DOM back to as if it were at the point just before it is given "loaded" with the PageSrc String. Effectively in VBA doing a pair of Set = Nothing , with either a Dim and Create Dom or Set = New type code line It serves no purpose usually in VBA. Effectively we reset a situation back to as it is. It can however be used through .Open
HTMLdoc.Write PageSrc 'EP2b(ii). Convert the HTML code into an HTML Document Object Model, DOM 'give it somehow the info it needs to work further? ---- Fills the DOM HTML .. Wiki Dom http://www.excelforum.com/showthread.php?t=1148621&page=3#post4441761
'HTMLdoc.body.innerHTML = PageSrc ' Most people do that, but The Write method of an HTML file is designed to convert the page source text into an HTML DOM document. Both methods achieve the same results. The more common way Body of the Page Source code when converting it to an HTML DOM document oustside of VBA. Withiin VBA it just works harder to achieve the same. This excludes the Meta data, Java scripts, and Class information from being converted. Generally speaking, this information is not used when retrieving only text data from a web page.
HTMLdoc.Close 'EP2b(iii) _ 2 b or not in 2b , that was the ?? http://www.excelforum.com/showthread.php?t=1148621&page=6.. Briefly When used outside VBA, some processes started by .Open() can or should be finished after the corresponding outside VBA .write(). This is done using .Close(). Once again this can be used in VBA through .Close. It has no conceivable merit or known as yet reason to use it in VBA. Pike thinks it It closes the document you have just written. As such he describes it as optional. He would also not have the HTMLdoc.Open. Kyle thinks nothing is open. Leith uses it but has made no comment to Date. This may be just his style, like my EP's just not including the HTMLdoc.Open 'EP2b(i)
Rem 3
Rem 3a) Directly

DocAElstein

01-09-2019, 09:27 PM

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

01-09-2019, 09:29 PM

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

01-09-2019, 09:54 PM

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

01-09-2019, 09:55 PM

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

DocAElstein

01-09-2019, 09:56 PM

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

DocAElstein

01-30-2019, 01:08 AM

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

01-30-2019, 01:18 AM

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

01-30-2019, 01:18 AM

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

02-03-2019, 04:46 PM

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

02-03-2019, 04:52 PM

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

02-03-2019, 08:06 PM

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

DocAElstein

02-05-2019, 08:44 PM

Positioning of procedure separation Line in the Visual Basic Development Environment

These are some notes based on a discussion here.. http://www.eileenslounge.com/viewtopic.php?f=30&t=31756
Lisa Green had noticed something strange in how VBA divides procedures.....

It appears that in VBA, that is to say in the Visual Basic Development Environment Window , ( that window seen by hitting Alt+F11 from a spreadsheet ) , the convention has been set to separate procedures by a line extending across the code pane Window.
We see these as appearing as a series of underscores, __________________ , extending across the Visual Basic Development Environment Window

End Sub ' The dividing line appears to us as a line of underscores ____

Usually, if we did write exactly this ' The dividing line appears to us as a line of underscores ____ ' , on that terminating line above , then we would not see those underscores, ____ , as they get hidden in the terminating line:
Hidden_____InDividingLine.JPG : https://imgur.com/7DyP9Om
2142
The above screenshot shows the simplest case of routines with no “space” in between. In that simple case, the position of the dividing line is as expected in between the procedures. The situation is a bit more complicated if there is a separation in between procedures….

Effect of blank lines ( or ‘commented lines ) In Between
Between procedures we may add blank lines or ' comment lines. If this is done, it appears that the convention has been set to place the line somewhere between the procedures in this blank/ ‘comment range, and the lines above the line “belong” to the procedure above, that is to say the last or preeceding procedure, and the lines below the line “belong” to the procedure below, that is to say the next procedure, http://www.eileenslounge.com/viewtopic.php?f=30&t=31756#p245845

The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________

Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _

Line continuation / Break points : single underscores _
We note in passing , that single underscores are used in coding generally to allow us to divide a single line of code into several lines for ease of reading. For example:

' http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row-*SOLVED*?p=10891#post10891
Sub LineContunuationUnderscores() ' https://docs.microsoft.com/en-us/dotnet/visual-basic/programming-guide/program-structure/how-to-break-and-combine-statements-in-code
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

' Without line breaks
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))

' With Line breaks
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))
' This is _
acceptable in _
or out of a procedure
End Sub
' This is _
acceptable in _
or out of a procedure_________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _________
Further, we note that the line continuation , sometimes called a line break, _ , also applies to comments whether in a procedure or between procedures:
' This is _
acceptable in _
or out of a procedure

_._________

Determining position of horizontal line dividing procedures when blank or comment lines are between procedures
Sir Narios .
The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________
Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _
There appear to be 3 scenarios to consider in order to place the line somewhere in between, ( 4 if you consider the simple case of all lines containing comments or all lines being blank )

Scenario 0
' _(0)
If all lines are blank, or all lines are full with comments ( which exclude line continuations )
No single underscores in any line
The break is immediately after the Last/ upper procedure. (This is the same as the case for no separation between routines )
Scenario 0 .JPG : https://imgur.com/pA4grFL
2143

Sub Scenario_0()
' _(0)
End Sub_______________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ______

Sub senario_0()
' _(0)
End Sub_______________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ________________
'
'
'
Sub surnario_0()
' _(0)
End Sub_______________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ________________________

Scenario 1
' _(i) 2141 SirNario_1.JPG . https://imgur.com/zmr2up2
If no line continuations are present and there is a one or more blank lines, then the line before the first blank line down from the upper routine is taken as the break point.
No single underscores in any line

Sub Senario_1()
' _(i)
End Sub
'
'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _________________________

Sub surnaria_1()
' _(i)
End Sub
'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _____________________________

''

'
Sub Sirnario_1()
' _(i)
End Sub_______________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ __________

'
'
Sub snaria_1()
' _(i)
End Sub

Scenario 2
' _(ii) 2144 SirNario_2.JPG : https://imgur.com/D2LqloV
If there are one or more line continuations present then the break point will be placed at the first blank line down after the last line after the line continuation … unless scenario (iii)

Sub Scnari_2()
' _(ii)
End Sub

''
'
' _

'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _____________________________

'

Sub Sernario_2()
' _(ii)
End Sub
'
'
' _
'
'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ____________________________

'
Sub Sirnarnio_2()
' _(ii)
End Sub

Scenario 3
' _ (iii) 2146 SirNario_3.JPG : https://imgur.com/ho56uBN
There are no blank lines after the first line looking down after the last line continuation looking down, or after the first line looking down after the last line continuation looking down all lines contain comments . In this case, the break is at the line after the line on which the line continuation is on.

Sub scenario_3()
' _(iii)
End Sub
''
' _
__________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ____________________________
'
'
Sub SirNario_3()
' _(iii)
End Sub

'
' _
'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _____________________________
'
'
Sub snuaro_3()
' _(iii)
End Sub
'

'
' _
__________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ ____________________________

Sub SirNario_3()

End Sub
'
' _
'_________________________________________________ __________________________________________________ __________________________________________________ __________________________________________________ _____________________________

Sub SurNario_3()

End Sub

DocAElstein

02-07-2019, 10:50 PM

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 & """" & " " & """" & " & "

DocAElstein

02-07-2019, 10:52 PM

This is the second part of the coding from the last post

This should be copied and pasted directly under the coding from the last post

' 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 """" ' 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
WotchaGot = WotchaGot & "Chr(" & Asc(Caracter) & ")" & " & "
'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) = Asc(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
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()
End Sub
'

DocAElstein

02-18-2019, 02:51 PM

Coding in support of this excelfox Thread:
llkslksjjsjfaslkjflkajflkjflfjj later sajfsladj

Option Explicit

'
' Range.Sort Example
Sub RangeSortExample()
range("G13:K19").Sort Key1:=range("G13:K19").Columns("B:B"), Order1:=xlAscending, Key2:=range("G13:K19").Columns("D:D"), order2:=xlAscending, MatchCase:=False, Key3:=range("G13:K19").Columns("E:E"), order3:=xlDescending, MatchCase:=False
End Sub ' Matchcase:=False '

' Simplist Sort
Sub SimpleArraySort()
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 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
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
' Approximate equivalent to the above routune, using VBA Range.Sort Method ' https://docs.microsoft.com/de-de/office/vba/api/excel.range.sort
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
'
Let RngCopy.Interior.Color = vbGreen
End Sub

Typical results:
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 SimpleArraySort() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()
More examples in next post.

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

1

2cWasB2AWasB5AWasB5

3ABWasB3AaWasB4AaWasB4

4AaWasB4ABWasB3ABWasB3

5AWasB5BWasB7BWasB7

6CWasB6bWasB8bWasB8

7BWasB7bcdeWasB9bcdeWasB9

8bWasB8CWasB6cWasB2

9bcdeWasB9cWasB2CWasB6

10
Worksheet: Sorting

DocAElstein

02-18-2019, 02:58 PM

Further Examples using the routines from the previous post
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 SimpleArraySort() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()

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

1

2cWasB2
32WasB8
6WasB7

3ABWasB3
6WasB7
32WasB8

4AaWasB4AWasB5AWasB5

5AWasB5AaWasB4AaWasB4

6CWasB6ABWasB3ABWasB3

7
6WasB7bcdeWasB9bcdeWasB9

8
32WasB8CWasB6cWasB2

9bcdeWasB9cWasB2CWasB6

10
Worksheet: Sorting

To reverse this to descending so that things “get smaller as you go down the rows”, you simply need to change
the > to a < in the array routine
and
the Order1:=xlAscending to Order1:=xlDescending in the VBA Range.Sort routine
_____ ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1

2cWasB2cWasB2cWasB2

3ABWasB3CWasB6CWasB6

4AaWasB4bcdeWasB9bcdeWasB9

5AWasB5ABWasB3ABWasB3

6CWasB6AaWasB4AaWasB4

7
6WasB7AWasB5AWasB5

8
32WasB8
6WasB7
32WasB8

9bcdeWasB9
32WasB8
6WasB7

10
Worksheet: Sorting

I intended developing the solution into a function, so as a start to this, the routine will be modified to take an Optional argument of 0 or 1 , with the default of 0 being the case for an Ascending list. I am not being particularly efficient with the coding, and will duplicate sections.

A full routine is posted in the next post

DocAElstein

02-19-2019, 10:52 PM

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

02-19-2019, 11:55 PM

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

02-20-2019, 12:12 AM

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

02-20-2019, 10:28 PM

'
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

02-21-2019, 01:15 PM

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

02-21-2019, 05:24 PM

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

02-21-2019, 05:47 PM

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

02-22-2019, 06:20 PM

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

02-22-2019, 06:56 PM

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

02-22-2019, 08:23 PM

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

03-02-2019, 10:44 PM

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

03-03-2019, 05:46 PM

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

03-03-2019, 09:16 PM

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

03-13-2019, 09:38 PM

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

03-13-2019, 09:45 PM

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

03-14-2019, 03:52 PM

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

DocAElstein

03-14-2019, 04:30 PM

recursion routine Called by routine ( Sub TestieSimpleArraySort8() ) from last post

' Main recursion routine below : Bubble Sorting in Arrays using multi columns values for sort criteria
Sub SimpleArraySort8(ByVal CpyNo As Long, ByRef arrIndx() 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(arrIndx(rOuter, Clm)) And IsNumeric(arrIndx(rInner, Clm)) Then ' Numeric case
If CDbl(arrIndx(rOuter, Clm)) > CDbl(arrIndx(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
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
Else ' Non numeric case
If UCase(CStr(arrIndx(rOuter, Clm))) > UCase(CStr(arrIndx(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrIndx(rOuter, Clm)) And IsNumeric(arrIndx(rInner, Clm)) Then
If CDbl(arrIndx(rOuter, Clm)) < CDbl(arrIndx(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arrIndx(rOuter, Clm))) < UCase(CStr(arrIndx(rInner, Clm))) Then
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
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
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(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 ' 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 SimpleArraySort8(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
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(arrIndx(), 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 SimpleArraySort8(CopyNo + 1, arrIndx(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub

DocAElstein

03-16-2019, 10:09 PM

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

'
Sub Call_Sub_Bubbles() ' 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 ' array to be referred to in all recursion routines, initially the original data range
Let arrTS() = RngToSort.Value
' Initial row indicies
Let Rs() = Evaluate("=Row(1:6)") '
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 Bubbles(1, arrTS(), strRows, " 1 Asc 3 Asc 2 Asc ")

' Demo output
Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrTS()
End Sub
'
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

DocAElstein

03-17-2019, 02:21 PM

'
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

DocAElstein

03-17-2019, 02:22 PM

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

03-17-2019, 02:59 PM

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

DocAElstein

03-17-2019, 03:25 PM

DocAElstein

03-17-2019, 08:23 PM

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

03-31-2019, 02:31 PM

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

04-02-2019, 03:16 PM

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 )

DocAElstein

04-02-2019, 03:17 PM

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

DocAElstein

04-02-2019, 03:19 PM

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

04-06-2019, 01:15 PM

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