Recurse recorded Macro?

English
#1

Have a recorded MACRO:

rem Looks for “►” in col A,
rem selects same row, col B
rem deletes value in col B
rem recurses to find next “►” …
rem repeats until nothing more in col A

sub DelDup
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object

rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService(“com.sun.star.frame.DispatchHelper”)

rem ----------------------------------------------------------------------
dim args1(20) as new com.sun.star.beans.PropertyValue
args1(0).Name = “SearchItem.StyleFamily”
args1(0).Value = 2
args1(1).Name = “SearchItem.CellType”
args1(1).Value = 1
args1(2).Name = “SearchItem.RowDirection”
args1(2).Value = false
args1(3).Name = “SearchItem.AllTables”
args1(3).Value = false
args1(4).Name = “SearchItem.SearchFiltered”
args1(4).Value = false
args1(5).Name = “SearchItem.Backward”
args1(5).Value = false
args1(6).Name = “SearchItem.Pattern”
args1(6).Value = false
args1(7).Name = “SearchItem.Content”
args1(7).Value = false
args1(8).Name = “SearchItem.AsianOptions”
args1(8).Value = false
args1(9).Name = “SearchItem.AlgorithmType”
args1(9).Value = 0
args1(10).Name = “SearchItem.SearchFlags”
args1(10).Value = 65536
args1(11).Name = “SearchItem.SearchString”
args1(11).Value = “►”
args1(12).Name = “SearchItem.ReplaceString”
args1(12).Value = “”
args1(13).Name = “SearchItem.Locale”
args1(13).Value = 255
args1(14).Name = “SearchItem.ChangedChars”
args1(14).Value = 2
args1(15).Name = “SearchItem.DeletedChars”
args1(15).Value = 2
args1(16).Name = “SearchItem.InsertedChars”
args1(16).Value = 2
args1(17).Name = “SearchItem.TransliterateFlags”
args1(17).Value = 1073743104
args1(18).Name = “SearchItem.Command”
args1(18).Value = 0
args1(19).Name = “SearchItem.SearchFormatted”
args1(19).Value = false
args1(20).Name = “SearchItem.AlgorithmType2”
args1(20).Value = 1
dispatcher.executeDispatch(document, “.uno:ExecuteSearch”, “”, 0, args1())

rem ----------------------------------------------------------------------
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = “ToPoint”
args2(0).Value = “$B$186”

dispatcher.executeDispatch(document, “.uno:GoToCell”, “”, 0, args2())

rem ----------------------------------------------------------------------
dispatcher.executeDispatch(document, “.uno:ClearContents”, “”, 0, Array())

rem ----------------------------------------------------------------------
dim args4(0) as new com.sun.star.beans.PropertyValue
args4(0).Name = “Sel”
args4(0).Value = false

dispatcher.executeDispatch(document, “.uno:GoToStartOfRow”, “”, 0, args4())
end sub

How do I get it to recurse until there ar no more values in col A ?

Macros how to put multiple value in this code: if oCell.value = 5 then
#2

The recorder makes more settings than needed. However, we can use the result without lots of .uno:GoToCell commands for which you anyway would need to find the target addresses from the selection.
Yo may try

sub aSuggestedSolution

REM a few lines of preparations.

cCtrl = ThisComponent.CurrentController
sheet = cCtrl.ActiveSheet
controllingRange = sheet.Columns(0) REM That's the leftmost column of the sheet
cCtrl.select(controllingRange) REM Now the sheet is prepared for the F&R steps.

REM Now comes the RECORDED part.
REM You could do it in a clearer and more concise way Writing the code from scratch.
 
rem define variables
dim document   as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

rem ----------------------------------------------------------------------
REM May contain lots of unneeded settings.
dim args1(20) as new com.sun.star.beans.PropertyValue
args1(0).Name = "SearchItem.StyleFamily"
args1(0).Value = 2
args1(1).Name = "SearchItem.CellType"
args1(1).Value = 0
args1(2).Name = "SearchItem.RowDirection"
args1(2).Value = true
args1(3).Name = "SearchItem.AllTables"
args1(3).Value = false
args1(4).Name = "SearchItem.SearchFiltered"
args1(4).Value = false
args1(5).Name = "SearchItem.Backward"
args1(5).Value = false
args1(6).Name = "SearchItem.Pattern"
args1(6).Value = false
args1(7).Name = "SearchItem.Content"
args1(7).Value = false
args1(8).Name = "SearchItem.AsianOptions"
args1(8).Value = false
args1(9).Name = "SearchItem.AlgorithmType"
args1(9).Value = 1
args1(10).Name = "SearchItem.SearchFlags"
args1(10).Value = 71680
args1(11).Name = "SearchItem.SearchString"
args1(11).Value = "►$" REM Will find the relevant character AT THE END of the content string.
args1(12).Name = "SearchItem.ReplaceString"
args1(12).Value = ""
args1(13).Name = "SearchItem.Locale"
args1(13).Value = 255
args1(14).Name = "SearchItem.ChangedChars"
args1(14).Value = 2
args1(15).Name = "SearchItem.DeletedChars"
args1(15).Value = 2
args1(16).Name = "SearchItem.InsertedChars"
args1(16).Value = 2
args1(17).Name = "SearchItem.TransliterateFlags"
args1(17).Value = 1073745152
args1(18).Name = "SearchItem.Command"
args1(18).Value = 1
args1(19).Name = "SearchItem.SearchFormatted"
args1(19).Value = false
args1(20).Name = "SearchItem.AlgorithmType2"
args1(20).Value = 2

dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args1())

rem ----------------------------------------------------------------------
REM You won't need this.
'dim args2(0) as new com.sun.star.beans.PropertyValue
'args2(0).Name = "Visible"
'args2(0).Value = false
'dispatcher.executeDispatch(document, ".uno:SearchResultsDialog", "", 0, args2())

REM This was the recorded search. Now comes the "designer action".
REM The found cells should be selected now. We can get them as a SheetCellRangesObject.

findings = cCtrl.Selection
REM Unfortunately current selections from sheets  aren't always returned with the same object type.
REM Therefore I harmonize this. To do so I use a helper function from my toolbox:
foundRanges = sheetCellSetAsRanges(findings)

REM Now comes the relevant action: Clear coliumn B in the found rows.

For Each rg In foundRanges
 With rg.RangeAddress REM The 1 means column "B".
  contentRg = sheet.getCellRangeByPosition(1, .StartRow, 1, .EndRow)
 End With
 contentRg.clearContents(23) REM Clears ordinaryx content and formulas. Doesn't touch attributes.
Next rg

end sub

with the helper function


Function sheetCellSetAsRanges(Optional pDiverse As Object)', Optional pSplitCollectByCellStyle As Boolean)
REM Usage of second parameter not yet implemented!
On Local Error Goto fail
If pDiverse.supportsService("com.sun.star.sheet.SheetCellRanges") Then
  sheetCellSetAsRanges = pDiverse
Else
Dim calcDoc As Object, unified As Object
  calcDoc = pDiverse.Spreadsheet.DrawPage.Forms.Parent REM Funny detour; thanks to Andreas Säger.
  unified = calcDoc.CreateInstance("com.sun.star.sheet.SheetCellRanges")
  unified.addRangeAddress(pDiverse.RangeAddress, False)
  sheetCellSetAsRanges = unified
EndIf
fail:
End Function

whitch helps to avoid the need of case distinctions.

#3

The following code written without the help of the recorder may suit your needs even better.

Sub doItWithoutTheSlotMachine()
sheet = ThisComponent.CurrentController.ActiveSheet
controllingRange = sheet.Columns(0) REM That's the leftmost column of the sheet
sd = controllingRange.createSearchDescriptor
With sd
 .SearchRegularExpression = True
 .SearchString            = "►$"
End With
findings = controllingRange.findAll(sd)
For Each rg In findings
 With rg.RangeAddress REM The 1 means column "B".
  contentRg = sheet.getCellRangeByPosition(1, .StartRow, 1, .EndRow)
 End With
 contentRg.clearContents(23) REM Clears ordinaryx content and formulas. Doesn't touch attributes.
Next rg
End Sub

It’s also a little bit shorter, and probably easier to understand.
No additional helper function used. The method findAll returns its result as a SheetCellRanges object anyway. We can forget about the detour via CurrentSelection.

Both solutions accept the “delete-it-marker” ► also with any string to the left, but only at the end of the cell’s content.
To change this (or different details) according to your needs is simple and doesn’t require a new recording session.

#4

THANK YOU,
⌡im

#5

It won’t be relevant in most cases, but for completeness I tested with a random data set of 100 000 rows measuring the runtime.
As expected due to the number of about 10000 subranges needing treatment in the loop (for the example) the result wasn’t exactly satisfying (>80 s on my system),
The enhanced code below accelerated the process by a factor of about 12.
In addition the enhancement allows for

  • Undoing all deletions in one step (if a mishap occurred e.g.).
  • Refining the final action by restricting it to a sub-selection within the 'findings1" by a second .findAll applied to those ranges, and by doing a replacement if wanted instead of the deletion.

Code connoisseurs may be interested.

Sub doItWithoutTheSlotMachineEnhanced()
doc       = ThisComponent
sheet     = doc.CurrentController.ActiveSheet
markedRgs = doc.createInstance("com.sun.star.sheet.SheetCellRanges")
REM The ranges in column B later to work on.
controllingRange         = sheet.Columns(0) REM That's the leftmost column of the sheet
sd        = sheet.createSearchDescriptor
With sd
 .SearchRegularExpression = True
 .SearchString            = "►$"
End With
findings1 = controllingRange.findAll(sd)
For Each rg In findings1
 ra = rg.RangeAddress
 ra.StartColumn = 1 : ra.EndColumn = 1
 REM Offset to column B without cursor creation
 markedRgs.addRangeAddress(ra, False)
Next rg
sd.SearchString = ".*"
REM Here 'any'. Used for testing "(?i)x". That's any string containing x or X.
findings2 = markedRgs.findAll(sd)
findings2.clearContents(23)
End Sub
1 Like
#6

Thank you to everyone the answered.
My solution is as follows:
Enable filtering
Filter colA on ► only
Delete all that show up
Turn off ► filter and re-alphabetize colB

Thank you again, ⌡im

1 Like

Impressum (Legal Info) | Datenschutzerklärung (Privacy Policy)   Content on this site is licensed under a Creative Commons Attribution Share Alike 3.0 license.