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

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 section is not for asking questions about writing your own macros.
Post Reply
User avatar
Lupp
Volunteer
Posts: 3542
Joined: Sat May 31, 2014 7:05 pm
Location: München, Germany

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

Post by Lupp »

(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 287 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

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

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 24.2 (new numbering) and older versions, PortableOpenOffice 4.1.7 and older, StarOffice 5.2
---
Lupp from München
User avatar
Lupp
Volunteer
Posts: 3542
Joined: Sat May 31, 2014 7:05 pm
Location: München, Germany

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

Post by Lupp »

The post above was updated by editing. The code was cleaned and slightly enhanced, the demonstration got an additional part.
On Windows 10: LibreOffice 24.2 (new numbering) and older versions, PortableOpenOffice 4.1.7 and older, StarOffice 5.2
---
Lupp from München
User avatar
Zizi64
Volunteer
Posts: 11353
Joined: Wed May 26, 2010 7:55 am
Location: Budapest, Hungary

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

Post by Zizi64 »

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

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; LO7.5.8 /Win7-10 x64Prof.
PortableApps/winPenPack: LO3.3.0-7.6.2;AOO4.1.14
Please, edit the initial post in the topic: add the word [Solved] at the beginning of the subject line - if your problem has been solved.
Post Reply