I have working code that I need help making a small change to and was wondering if someone could assist. Currently the code writes to cell A14 and B14 I would like the removal of writing to cell B14 and so only A14 would occur. Also, the code at Step 4 (below) needs to be changed. The change I need is to find the text number in the cell below the positive result. In my example in the spreadsheet it finds a match in cell D28 so it would go to the cell below, cell D29 in my example and write the number 7 to cell A14. I’ve attached the spreadsheet.
Even if you only have time for the first change that would be greatly appreciated. Bob
The current code does the following:
(Step 1) The code starts with the number in cell A1 looking for a match in the range A20:A34,D20:D100,I20:I100,N20:N100. A positive match occurs only when the code finds the number from A1 plus text in the first cell to right of a matched number (formatted as text). In the sample spreadsheet A1 has a 9 in it and there is a 9 in cell I28 but no text in cell J28 so it’s a false result.
(Step 2) In cell D28 it’s a positive result because of the text numbers in cells E28.
(Step 3) Next the code goes to the cell to the right of it and uses the first number 10. The code then searches for a match in the range M1:M15 and writes the second number in the set of numbers 25 in the next available cell to the right of it and would continue the process in future writes. In my example 25 would be written in cell N9.
(Step 4) The code then would write the first number in the set of numbers, (10 in my sample) to either cell A14. If cell A14 has a number in it write it to cell B14.
(Step 5) The code then clears content. In my sample spreadsheet that would be cells E28, F28, G28 and H28 would be cleared.
option explicit Sub Find on local error goto bug dim oDoc as object, oSheet as object, addr1(), i&, j&, sA1$, oRange1 as object, oCell2 as object, s1$, s2$, data1(), oRange2 as object, oCellE as object, sE$ oDoc=ThisComponent oDoc.lockControllers oDoc.addActionLock oSheet=oDoc.Sheets.getByName("Sheet1") sA1=oSheet.getCellRangeByName("A1").string addr1=array("A20:A34", "D20:D109", "I20:I109", "N20:N109") for i=lbound(addr1) to ubound(addr1) oRange1=oSheet.getCellRangeByName(addr1(i)) data1=oRange1.getDataArray() for j=lbound(data1) to ubound(data1) 'iterate numbers from cells A (D, I, N) s1=data1(j)(0) if s1=sA1 then 'numbers is the same like from A1 oCell2=oSheet.getCellByPosition(oRange1.RangeAddress.StartColumn+1, oRange1.RangeAddress.StartRow+j) '1st cell to right (column B, E etc.) s2=oCell2.string if testValue(s2) then writeToM(oSheet, s2) writeToA14(oSheet, s2) 'write to cells A14 or B14 if i=0 then 'column A is iterated oRange2=oSheet.getCellRangeByName(addr1(i+1)) oCellE=oSheet.getCellByPosition(oRange2.RangeAddress.StartColumn+1, oRange2.RangeAddress.StartRow+j) if s2<>sE then oCell2.string="" 'A28 isn’t equal to E28 so clear A28 - else oRange2=oSheet.getCellRangeByPosition(oCell2.CellAddress.Column, oCell2.CellAddress.Row, oCell2.CellAddress.Column+3, oCell2.CellAddress.Row) oRange2.clearContents(23) end if end if end if next j next i goto final bug: msgbox(Error & chr(13) & "Line: " & Erl & chr(13) & "Err: " & Err, 16) final: 'turn on the Screen Update and AutoCalculate oDoc.unlockControllers oDoc.removeActionLock End Sub Sub writeToM(oSheet as object, s$) dim oRange as object, i&, oCell as object, sM$, data(), j&, p() p=split(s, "-") oRange=oSheet.getCellRangeByName("M1:M15") data=oRange.getDataArray for i=lbound(data) to ubound(data) sM=data(i)(0) if sM=p(0) then j=0 do oCell=oSheet.getCellByPosition(oRange.RangeAddress.StartColumn+j, oRange.RangeAddress.StartRow+i) j=j+1 loop while oCell.string<>"" with oCell .string=p(1) .NumberFormat=1 .ParaAdjust=1 'Align Center end with end if next i End Sub Sub writeToA14(oSheet as object, s$) 'write to A14/B14 dim oCell as object, p() p=split(s, "-") oCell=oSheet.getCellRangeByName("A14") 'A14 if oCell.string<>"" then 'A14 isn’t empty so get the cell B14 oCell=oSheet.getCellByPosition(oCell.CellAddress.Column+1, oCell.CellAddress.Row) 'B14 end if with oCell .string=p(0) .NumberFormat=1 .ParaAdjust=3 .CharWeight=com.sun.star.awt.FontWeight.BOLD end with End Sub Function testValue(s$) as boolean 'return True if the string s$ agrees with the specified regular expression dim pole(2), oFind, oFindParam, oFound, oStart, oEnd, iCount% oFind=CreateUnoService("com.sun.star.util.TextSearch") 'searching for string oFindParam=CreateUnoStruct("com.sun.star.util.SearchOptions") With oFindParam .algorithmType=com.sun.star.util.SearchAlgorithms.REGEXP .searchString="(^\d±\d+$)" 'Number(s)-Number(s) End With oFind.setOptions(oFindParam) oFound=oFind.searchForward(s, 0, len(s)) oStart=oFound.startOffset() oEnd=oFound.endOffset() iCount=oFound.subRegExpressions()-1 if iCount=-1 then testValue=false else testValue=true End Function
FIND FIX.ods (10.2 KB)
[erAck: edited to surround code with ``` lines for proper display, see This is the guide - How to use the Ask site? - #6 by erAck , also replaced typographic double quotes with ASCII double quote characters for correctness.
.searchString="(^\d±\d+$)" seems wrong, whatever the original intention of