Rearrange Arrrays: Flip Functions (for reverse search e.g.)

Creating Extension - Shared Libraries
Forum rules
For sharing working examples of macros / scripts. These can be in any script language supported by OpenOffice.org [Basic, Python, Netbean] or as source code files in Java or C# even - but requires the actual source code listing. This forum is not for asking questions about writing your own macros.

Rearrange Arrrays: Flip Functions (for reverse search e.g.)

Postby Lupp » Wed Sep 27, 2017 10:16 pm

(Editing: Sorry! I first made a mess of this by prematurly posting still buggy code.)
Code now thoroughly revised and tested.
Acting on a suggestion by @Zizi64 Subs and a demo for In-Situ-Flipping were added. [/b] The focus as I see it is on the direct passing of flipped arrays to standard functions, however.


Now and then we have to search an array for a match using MATCH or VLOOKUP e.g. and need to do so in reverse order: bottom up or right to left.
Solutions I saw or designed myself used either complicated formulas with tricky constructs within OFFSET or relied on helper columns (/rows/arrays).

A few years ago I sketched in BASIC a few functions capable of flipping arrays to prepare them to get passed to a SEARCH, VLOOKUP or HLOOKUP call working then as if it processed the original array in reverse order. Because of recent demand I polished the code a bit and supply it here now. It is contained in the following demo, but I also post it in plain text below. Enjoy it.

FlipFunctions_3a_.ods
(24.39 KiB) Downloaded 23 times


The code published first contained a few useless statement blocks and some misleading comments. The erratic statements wouldn't do harm. Nonetheless I recommend to replace the old code with the newer version. For internal (inside BASIC) application of the functions the limitation to arrays with 1-based indexes was resolved.

The reworked code is to find below. It also is contained in the new attachment, where a demo was added showing how to match backwards and how to get VLOOKUP to return values from columns left of the lookup column.

Code: Select all   Expand viewCollapse view
REM  *****  BASIC  *****
REM Module Standard.reArrange

REM Module Version 0.1   of 2017-09-27 by Wolfgang Jäger based on older sketches
REM Module Version 0.2   of 2017-10-01 by Wolfgang Jäger
REM                      Useless (but not evil-doing) parts removed, comments enhanced and rectified
REM                      Functions made independent of 1-based indexing.
REM Module Version 0.2.1 of 2017-10-01 by Wolfgang Jäger
REM                      Bugfixes concerning For loops

Option Explicit

REM As a kind of "horizontalFlipString(pString)" added here though not related to 2D-flips
Function reverseString(pS As String) As String
If pS="" Then
   reverseString = ""
   Exit Function
End If
   Dim n As Long, k As Long
n = Len(pS)
   Dim cA(1 To n) As String
For k = 0 To n - 1
   cA(k+1) = Mid(pS, n - k, 1)
Next k
pS = Join(cA, "")
reverseString = pS
End Function

REM All the arrays passed to these functions need to be 2D as all arrays passed via parameters by calls from Calc formulas are anyway.
REM Calls from user code might have also use for differently dimensional arrays. A respective variant is not yet implemented.
REM However, the functions do not insist on the array indexes being 1-based.

Function centralFlip2D(pRange)
REM The function is applicable to any m x n - range where m, n are positive integers, the value 1 allowed in both places.
If NOT IsArray(pRange) Then
         Dim hRange(1 To 1, 1 To 1)
   hRange(1,1) = pRange
   pRange = hRange
EndIf
   Dim aNum As Long, bNum as Long, a As Long, b As Long
   Dim ml As Long, mu As Long, nl As Long, nu As Long, m As Long, n As Long
   Dim h
ml = Lbound(pRange(),1) : mu = Ubound(pRange(),1) : m = mu - ml +1
nl = Lbound(pRange(),2) : nu = Ubound(pRange(),2) : n = nu -nl + 1
aNum = m \ 2
REM The upper half and the lower half of the array are mirrored now over the center excluding the middle row if one exists at all.
bNum = n
For a = ml To ml + aNum - 1
   For b = nl To nl + bNum - 1
      h = pRange(a, b)
      pRange(a, b) = pRange(mu+ml-a, nu+nl-b)
      pRange(mu+ml-a, nu+nl-b) = h
   Next b
Next a
REM Only in case of an odd number of rows two half rows need mirroring one onto the other.
REM Including this in the above loop for 'a' would mirror twice and thus lead back to the original middle row.
REM A rejected alternative was to limit the loop for b conditionally.
If (m MOD 2) = 1 Then
   a = ml + aNum
   bNum = n \ 2
   For b = nl To nl + bNum -1
      h = pRange(a, b)
      pRange(a, b) = pRange(a, nu+nl-b)
      pRange(a, nu+nl-b) = h
   Next b
EndIf
centralFlip2D = pRange
End Function

Function verticalFlip2D(pRange())
REM The function is applicable to any m x n - range where m, n are positive integers, the value 1 allowed in both places.
If NOT IsArray(pRange) Then
         Dim hRange(1 To 1, 1 To 1)
   hRange(1,1) = pRange
   pRange = hRange
EndIf
   Dim aNum As Long, bNum as Long, a As Long, b As Long
   Dim ml As Long, mu As Long, nl As Long, nu As Long, m As Long, n As Long
   Dim h
ml = Lbound(pRange(),1) : mu = Ubound(pRange(),1) : m = mu - ml +1
nl = Lbound(pRange(),2) : nu = Ubound(pRange(),2) : n = nu -nl + 1
aNum = m \ 2
REM The upper half and the lower half of the array are mirrored now over the horizontal middle axis excluding the middle row if one exists at all.
bNum = n
For a = ml To ml + aNum - 1                 'Row index a
   For b = nl To nl + bNum - 1             'Column idex b
      h = pRange(a, b)
      pRange(a, b) = pRange(mu+ml-a, b)
      pRange(mu+ml-a, b) = h
   Next b
Next a
REM In case of an odd number of rows the middle row can remain untouched.
verticalFlip2D = pRange
End Function

Function horizontalFlip2D(pRange())
REM The function is applicable to any m x n - range where m, n are positive integers, the value 1 allowed in both places.
If NOT IsArray(pRange) Then
         Dim hRange(1 To 1, 1 To 1)
   hRange(1,1) = pRange
   pRange = hRange
EndIf
   Dim aNum As Long, bNum as Long, a As Long, b As Long
   Dim ml As Long, mu As Long, nl As Long, nu As Long, m As Long, n As Long
   Dim h
ml = Lbound(pRange(),1) : mu = Ubound(pRange(),1) : m = mu - ml +1
nl = Lbound(pRange(),2) : nu = Ubound(pRange(),2) : n = nu -nl + 1
aNum = m
REM The left half and the right half of the array are mirrored now over the vertical middle axis excluding the middle column if one exists at all.
bNum = n \ 2
For b = nl To nl + bNum -1                  'Column index
   For a = ml To ml + aNum -1              'Row index
      h = pRange(a, b)
      pRange(a, b) = pRange(a, nu+nl-b)
      pRange(a, nu+nl-b) = h
   Next a
Next b
REM In case of an odd number of columns the middle column can remain untouched.
horizontalFlip2D = pRange
End Function

Now the module containing the mentioned Subs for flipping in-situ: Output to the range the data came from.
No attempt made to include formats!
Code: Select all   Expand viewCollapse view
REM  *****  BASIC  *****

REM Module 'Standard.subForSelection'
Sub flipInSituCaller(pEvent)         ' The pEvent is supposed to be raised by an OK-Button click (Release).
REM Should be assigned to the event 'Mouse button released' of an OK button.
If (pEvent.X<0) OR (pEvent.X>pEvent.Source.Size.Width) OR (pEvent.Y<0) OR (pEvent.Y>pEvent.Source.Size.Height)Then exit Sub
choice = pEvent.Source.Model.Tag     ' In the property editor of the 'Button' the .Tag is named "Additional information". (Bad idea.)
Select Case choice
    Case "central", "vertical", "horizontal": flipInSitu(choice)
    Case Else                               : MsgBox("No flip action defined.")
End Select
End Sub

Sub flipInSitu(pChoice)
theRange = ThisComponent.CurrentSelection
If NOT theRange.SupportsService("com.sun.star.sheet.SheetCellRange") Then Exit Sub
dA = theRange.GetDataArray           ' Always 0-based!
um = Ubound(dA) : un = Ubound(dA(0))
Dim wD(0 To um, 0 To un)             ' The dA is a 1D-column-array of 1D row-arrays. My centralFlip2D() cannot handle it directly.
For y = 0 To um                      ' Of course you may write either a specialised flipping routine for this kind of structure
    For x = 0 To un                  ' or modify the body of 'centralFlips2D()' to alternatively handle it. (Not very efficient?)
        wD(y, x) = dA(y)(x)          ' Here I preferred to pay with RAM. Don't use the routine for a complete sheet of 2^30 cells.
    Next x
Next y
Select Case pChoice
    Case "vertical"  : wD = verticalFlip2D(wD)
    Case "horizontal": wD = horizontalFlip2D(wD)
    Case "central"   : wD = centralFlip2D(wD)
    Case Else        : Exit Sub
End Select
For y = 0 To um
    For x = 0 To un
        dA(y)(x) = wD(y, x)
    Next x
Next y
theRange.SetDataArray(dA)
End Sub
Last edited by Lupp on Tue Oct 03, 2017 3:02 pm, edited 4 times in total.
On Windows 10: LibreOffice 5.4.2 and older versions, PortableOpenOffice 4.1.3 and older, StarOffice 5.2
---
Maybe we might! (Create a powerful UFO: United Free Office)
Lupp from München
User avatar
Lupp
Volunteer
 
Posts: 1523
Joined: Sat May 31, 2014 7:05 pm

Re: Rearrange Arrrays: Flip Functions (for reverse search e.

Postby Lupp » Sun Oct 01, 2017 10:56 am

The post above was updated by editing. The code was cleaned and slightly enhanced, the demonstration got an additional part.
On Windows 10: LibreOffice 5.4.2 and older versions, PortableOpenOffice 4.1.3 and older, StarOffice 5.2
---
Maybe we might! (Create a powerful UFO: United Free Office)
Lupp from München
User avatar
Lupp
Volunteer
 
Posts: 1523
Joined: Sat May 31, 2014 7:05 pm

Re: Rearrange Arrrays: Flip Functions (for reverse search e.

Postby Zizi64 » Sun Oct 01, 2017 1:29 pm

Just a tip:
Create Subroutines based on this code for reverse the cell contents in a selected cell range into same place.

My older code snippet has not such efficient method as your code has. (I have applied double full "for" cycles, and a huge array for temporary storage of the cell contents...)

Code: Select all   Expand viewCollapse view
REM  *****  BASIC  *****

Option explicit

Sub Reverse_RowsAndColumns

Dim oDoc as object
Dim oView as object
Dim oSheet as object
Dim oCell as object
Dim oSel as object
Dim oAddr as object
Dim nSCol as long
Dim nSRow as long
Dim nECol as long
Dim nERow as long
Dim i as long
Dim j as long

   oDoc = ThisComponent
   oView = oDoc.getCurrentController()
   oSheet= oView.getActiveSheet()
   oSel = oDoc.getCurrentSelection()
   oAddr = oSel.getRangeAddress()

   nSCol = oAddr.StartColumn
   nSRow = oAddr.StartRow
   nECol = oAddr.EndColumn
   nERow = oAddr.EndRow

   if nSRow>=nERow and nSCol>=nECol then
      MsgBox( "Error:Too less cells are selected!")
      Exit sub
   end if
   if (nERow-nSRow)>65536 or (nECol-nSCol)>1024   then
      MsgBox( "Error: Too many rows/columns are selected!")
      Exit sub
   end if

Dim CellContent(nERow-nSRow+1, nECol-nSCol+1)

   for j = nSCol to nECol
      for i = nSRow to nERow   
         oCell = oSheet.getCellByPosition(j,i)
         CellContent(i-nSRow,j-nSCol)= oCell.formulalocal
      next i
   next j

   for j = nSCol to nECol
      for i = nSRow to nERow
         oCell = oSheet.getCellByPosition(j,i)
         oCell.formulalocal=CellContent(nERow-i,nECol-j)
      next i
   next j

End Sub
rem ----------------------------------------------------------------------
Tibor Kovacs, Hungary; LO4.4.7, LO5.3.7 on Win7x64Prof.
PortableApps, WinPenPack: LO3.3.0-LO5.4.2 and AOO4.1.3
Please, edit the topic's initial post, and add the word "[Solved]" at the beginning of the subject line - if your problem has been solved.
User avatar
Zizi64
Volunteer
 
Posts: 6069
Joined: Wed May 26, 2010 7:55 am
Location: Budapest, Hungary


Return to Code Snippets

Who is online

Users browsing this forum: No registered users and 1 guest