Hello
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 ± was.]