Batch: Stop Cortana Memory Hog

Googling for "Microsoft Windows 10 Cortana®" reveal MANY complaints about memory loss. My experience is 28-33% reported by Task Manager even when Cortana (voice listening and response services) are DISABLED / "inactive"! The best advice found to-date has been "remove" or "rename it"!

Usually a BAD workaround! Especially since it was IMPOSSIBLE to do it manually.
Therefore this BATCH file is offered with the warning "EXAMPLE only! Do *NOT* attempt this on any computer. This batch file is ONLY OFFERED as an example of the "IF" statement and batch logic flow."

@echo off

rem set statusstring="end of %0"

SET /P ISADMIN=Are you RUNNING THIS AS ADMIN (usually from a shortcut 'RUN AS ADMIN') Y/N: =
if /I NOT "%ISADMIN%"=="Y" goto OOPS
rem it can take 20-30% or more of RAM
rem can't MANUALLY RENAME or MOVE it because Task Manager RELOADS it
rem SOLUTION: replace MANUAL steps with BATCH commands

rem @echo on

echo step 1 kill SearchUI and rename

for %%x in (ActionUriServer.exe PlacesServer.exe RemindersServer.exe RemindersShareTargetApp.exe SearchUI.exe backgroundTaskHost.exe) do IF EXIST %%x taskkill /T /F /PID %%x

rem taskkill /T /F /PID SearchUI.exe
rem taskkill /T /F /PID backgroundTaskHost.exe

echo step 2 rename folder and/or SearchUI.exe to stop RESTART of Cortana
IF EXIST C:\Windows\SystemApps\Microsoft.Windows.Cortana_cw5n1h2txyewy pushd C:\Windows\SystemApps\Microsoft.Windows.Cortana_cw5n1h2txyewy
IF EXIST SearchUI.exe rename SearchUI.exe zSearchUI.exe
pushd C:\Windows\SystemApps
IF EXIST Microsoft.Windows.Cortana_cw5n1h2txyewy move /Y Microsoft.Windows.Cortana_cw5n1h2txyewy Microsoft.Windows.½Cortana_cw5n1h2txyewy

dir /ad Microsoft.Windows.?C*

set statusstring=RUN AS ADMIN (right click on "%0" and Run As Admin)
echo %statusstring%

echo ....


What about TRIM() ?

What about TRIM() for removing white space from strings!
Although it is a really handy BUG-ELIMINATOR for whenever a user pastes into your (MS-Access) application, STILL this attachment demonstrates that TRIM only works on outer spaces, not other white space characters like ASCII characters 9, 10, 12, 13. (vbTab, vbLf, Formfeed, vbCr)

' Save  this in a VBS file on your desktop for a VISUAL DEMO comparing three string cleaning functions below
Dim someOtherString, someOtherString1, someOtherString2, someOtherString3

someOtherString1 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf
someOtherString2 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf
someOtherString3 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf

msgbox chr(34) & trim(someOtherString1) & chr(34),,"Trim"
msgbox chr(34) & nibble(someOtherString2) & chr(34),,"Nibble"
msgbox chr(34) & chomp(someOtherString3) & chr(34),,"Chomp"
' --------------------
Function chomp(somestring)
if len(somestring) >= 1 then 
while (asc(right(somestring,1)) <= 13 ) 
   somestring = left(somestring, len(somestring)-1) 
end if 
chomp = somestring  
End Function 

' -------------------- 

Function nibble(somestring) 
 if len(somestring) >= 1 then 
   while (asc(left(somestring,1)) <= 13 ) 
somestring = right(somestring, len(somestring)-1) 
end if 
nibble = somestring  
End Function


Print Unique Footer Header with Tabs

Problem:  You've been given  20 minutes to update 3 tabs of a 25 Tab *MONSTER* Spreadsheet, and REPORT your updates ....  Some are Landscape and some are Portrait.  Most are 5+ pages long.

How to make page number, sheet name and file name show in header and footer for your meeting in 20 minutes?

Sub Write_Header_Footer_from_Many_Tabbed_Workbook()
 Dim qystring, howmany, menudefault, sht
 'THIS IS FOR A XLS OF MANY TABS - sets the header, footer, and margins of each tab
 If Not ActiveWorkbook.Saved Then
 qystring = "nonemptystring"
 howmany = Sheets.Count
 menudefault = "OK to wait " & howmany * 10 & " seconds " ' Set default.
 qystring = InputBox("Wait 10 seconds each while header/footers written for " & howmany & " tabs?" _
 & vbCrLf & vbCrLf & "Enter Yes / No (or press 'Escape Key' to Skip)", "Enter Yes / No (or press 'Escape Key' to Skip)", menudefault)
 If qystring > "" Then qystring = UCase(Left(qystring, 1))
 'qystring = MsgBox(menudefault & " for " & howmany & " tabs?", vbYesNoCancel, "Write Tab Names to Header and Footer")
 Loop Until ((qystring = "N") Or (qystring = "Y") Or (qystring = "O") Or (qystring = ""))
 End If 'if not saved
 If UCase(Left(qystring, 1)) = "N" Then
 Exit Sub
' If qystring <> vbYes Then Exit Sub 'this line is if using msgbox alternative to inputbox above
 For Each sht In Sheets
 With sht.PageSetup
 .CenterHeader = "&A"
 .RightFooter = "Page &P of &N"
 .CenterFooter = "&08" & "&F" 'to show full (network) path use ' Me.Path & "/" & vbCrLf & "&F"
 .LeftFooter = "&D &T"
 .FitToPagesWide = 1
 .FitToPagesTall = 999
 .PrintTitleRows = "$1:$1"
 If (.Orientation = xlLandscape) Then
 .LeftMargin = Application.InchesToPoints(0.25)
 .RightMargin = Application.InchesToPoints(0.25)
 .TopMargin = Application.InchesToPoints(0.65)
 .BottomMargin = Application.InchesToPoints(0.65)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 .LeftMargin = Application.InchesToPoints(0.5)
 .RightMargin = Application.InchesToPoints(0.5)
 .TopMargin = Application.InchesToPoints(0.5)
 .BottomMargin = Application.InchesToPoints(0.5)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 End If
 End With
 Next sht
 End If ' vbyes
 End Sub

Macro: datetimestamp()

Appends date/time stamp to current cell.

Sub datestamp()
Dim strWhatTime
 strWhatTime = Format(Now(), "mm-dd-yy hh:mm:ss ddd")
 If ActiveCell.Value = "" Then
 ActiveCell.Value = strWhatTime
 '& (tempp - Int(temp))
 'ActiveCell.Value = Format(Now(), "c") '& (tempp - Int(temp))
 ActiveCell.Value = ActiveCell.Value & " " & strWhatTime
 End If
End Sub
'ActiveCell.FormulaR1C1 = "11/1/2011"

Merge with Zero Data Loss

This macro is best called by assigning it to a short-cut key-sequence, e.g. "Ctrl-Shift-M"(erge).  Do this in the Macro Edit dialog by the Excel short-cut sequence Alt-T-M-M (See SWF video - will run in most browsers: IE, Chrome, Firefox). It calls "nibble" which has it's own Post, but is also included below.

Sub mergeselection()
 Dim strTemp As String
 Dim youAreHere As Object
 Dim cc, k As Integer
 Set youAreHere = ActiveCell
' MsgBox ActiveCell.Address
' MsgBox Selection.Rows.Count
 For Each cc In Selection.Cells
 strTemp = strTemp & vbCrLf & cc.Value
 'strTemp = strTemp & vbCrLf & k + 1 & " " & cc.Value
 'k = k + 1
 Next cc
 With Selection  'With Selection is left over from macro recording
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlBottom
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 ' .MergeCells = False
 End With
 Application.DisplayAlerts = False
 Application.DisplayAlerts = True
 strTemp = nibble(strTemp) '& vbCrLf
 With youAreHere
 youAreHere.Value = strTemp
 youAreHere.HorizontalAlignment = xlLeft
 youAreHere.VerticalAlignment = xlTop
 End With
End Sub

' ===========================
Private Function nibble(somestring)
 'Dim islf
 If Len(somestring) >= 1 Then
 While (Asc(Left(somestring, 1)) <= 13) 'this will eat vbTab chr(9) !!!
 ' islf = asc(right(somestring,1))
 somestring = Right(somestring, Len(somestring) - 1)
 End If
 nibble = somestring
End Function


Excel to the Horse Races

Excel to the Horse Races
A working demonstration of unit conversion between old and new methods.

In this case COMPARE same Horse in different TRACKS and CONDITIONS:
furlongs, meters, feet, yards!  (Screenshots and download links below).

Conversion Demonstration - furlongs, meters, yards, miles

BEST PRACTICE ALERT: TEST your default security
and SCAN BEFORE downloading ANY product with MACROs.
This can be handled by most modern anti-virus software (I use
Webroot) *AND* by setting your Excel, or Word Options | Trust settings to highest security.

Consumer bears full responsibility to scan for unexpected code errors, malware or viruses.

http://excel-on-demand/wp-content/uploads/2017/01/equus044b1.xlsm (optional Active-X button and macro in first sheet to simplify default setting.)

http://excel-on-demand/wp-content/uploads/2017/01/equus044b2.xlsx (no local macro: ActiveX buttons only work in local tab: use a "form button" element to if you want to call a button handler from the local macro template in folder "XLStart")

Excel Macro Autonumber NonBlanks

Sub NumbernonBlankTestLines()
' user must manually highlight range in Column A
Dim msgs, qy, rep
Dim testcount, r, c As Integer,
Dim startHere As Range, rngSelected As Range
Dim markblank, enforcesinglerowblank As Boolean
enforcesinglerowblank = False

' MsgBox "last cell is " & findlastusedcell()
' use if we add feature to insert column A and auto-select range

testcount = 0

Set startHere = ActiveCell
Set rngSelected = Selection

If TypeName(Selection) = "Range" Then
If Selection.Areas.Count = 1 Then
' MsgBox "selected rows is " & rngSelected.Rows.Count & vbCrLf & "columnn is " & ActiveCell.Column

If rngSelected.Rows.Count < 2 Or ActiveCell.Column <> 1 Then GoTo oops

' magic starts here
'Selection.Name = "eraseme"
markblank = False
'MsgBox rngSelected.Rows.Count

If WorksheetFunction.CountA(rngSelected) > 1 Then
qy = MsgBox("OVERWRITE existing DATA?", vbOKCancel, "WARNING!")
If qy = vbCancel Then
Exit Sub
End If
End If
For r = 1 To rngSelected.Rows.Count


If r = 1 Then
If rngSelected(r).Offset(0, 1) = "" Then
MsgBox rngSelected(r).Offset(0, 1).Value
GoTo oops
End If
End If

'case not blank
If rngSelected(r).Offset(0, 1) > "" Then
If enforcesinglerowblank And markblank Then
GoTo doublelineerror
ElseIf Not markblank Or Not enforcesinglerowblank Then
markblank = Not markblank
rngSelected(r).Value = testcount + 1
' markblank = False Else markblank = True
testcount = testcount + 1
End If
'case blank
ElseIf rngSelected(r).Offset(0, 1) = "" Then
If enforcesinglerowblank And Not markblank Then
GoTo doublelineerror
ElseIf markblank Then
markblank = Not markblank
End If
Else: MsgBox
"Unknown", vbCritical, "Error!"

End If

Next r
' GoTo A1
MsgBox "Numbered " & testcount & " rows"
'measure column B begin and end
'make temporary range from A2: to match B begin to B end

'tbd select column A
'if selection < 2 rows warn and exit
'for each row in A, test adjacent cell B has value - number A, set flag notblank
'if flag notblank then next row should be blank, else warn andexit else skip to next
'if flag notblank, then next row should NOT be blank, else warn and exit, else number A
"Please select only one area.", vbInformation
End If
End If
Exit Sub

MsgBox "Only one row per test, MUST be separated by exactly one blank row: see Test# " & testcount, vbCritical, "Halted / Config Error"

Exit Sub

MsgBox "HALTED: must select multiple continuous rows within column A, alongside alternating data in column B" & vbCrLf _
& "and first selected row is NOT blank", vbCritical, "SELECTION ERROR"

End Sub

Auto Metrics Chart Demo

Sample Chart Demo

auto progress chart
auto progress chart sample
The working, customizeable chart demonstrates "automatic metrics" - it gives you timely reporting with just a quick attachment or a screenshot from the current Test XLS Suite being executed.

click chart thumbnail at right for full screenshot. Download XLS from link[s] above. Downloading from Google will require (a) having and (b) signing in to a Google account.

The Sample Test Suite in left columns will automatically tabulate the
progress summmary and chart on the right. This is done without
pivot tables, to give more flexibility and less maintenance.The benefit is for both individuals AND teams to be able to report whenever asked yet with minimal interruption.