ReDim Preserve , Can Anybody help me how to Re-Write in Calc StarBASIC Macro Code for the Below VBA Code?

English
, , ,
#1

Hi Friend,
Can anyone help me, how to Re-Write the StarBASIC Macro Code for the below VBA Code ?
i tried but i got failure…Please help me…

Sub ReSize_Preserve_DynamicArr()

Dim AnimationFilms() As Variant
Dim r As Range
Dim AnimationCounter As Long, LoopCounter As Long

Worksheets("Sheet1").Activate
For Each r In Range("A3", Range("A2").End(xlDown))
    If r.Offset(0, 4).Value = "Animation" Then
           AnimationCounter = AnimationCounter + 1
       ReDim Preserve AnimationFilms(1 To 5, 1 To AnimationCounter)
       
       For LoopCounter = 1 To 5
            AnimationFilms(LoopCounter, AnimationCounter) = r.Offset(0, LoopCounter - 1).Value
       Next LoopCounter       
    End If
Next r

Worksheets.Add
 Range("A3", Range("A3").Offset(4, UBound(AnimationFilms, 2) - 1)).Value = AnimationFilms

Worksheets.Add
Range(ActiveCell, ActiveCell.Offset(UBound(AnimationFilms, 2) - 1, 4)).Value = Application.Transpose(AnimationFilms)

End Sub

Here, is the Excel Data Screen Shot

image
image747×404 45 KB

Here, is the Result ,After Running VBA Macro Code
image

and
image

#2

So you wish to filter and sum by some condition/value? Why do you try this with macros, when a “regular” filter will do? (Especially as you seem to be not to versed with macros.)

1 Like
#3

Hi Wanderer, yes, we can use Filter Function. But, I want to learn How to Re-Write Macro in StarBASIC Calc Macro From VBA.

Using ReDim Array() or ReDim Preserve Array()

#4

@Wanderer: This pushy jerk has already addressed the same question privately to @sokol92 and me.
My answer there was:

def filter_by_E(criteria="Animation"):
    doc = XSCRIPTCONTEXT.getDocument()
    sheet = doc.Sheets["Sheet1"]
    cursor = sheet.createCursorByRange(sheet["A1"])
    cursor.collapseToCurrentRegion()
    data = cursor.DataArray
    out = [ row for row in data if row[-1]==criteria] # [-1] →last Column 
    
    cursor.gotoOffset(0, len(data))
    cursor.collapseToSize(len(out[0]), len(out))
    cursor.DataArray = out
#5

I assure you that the part that is specifically about using the ReDim Statement will work in StarBASIC just like it does in VBA. But everything else - reading from the cells of a sheet, offset, creating new sheets - it’s all so specific to Excel that it’s simply impossible to translate it into StarBASIC, it’s done in a completely different way in Calc. So what are you having trouble with (i tried but i got failure)?

1 Like
#6

Hi JohnSun , I want to ReWrite Macro in StarBASIC … How to get that Results …

#7

Use extensions XRay or MRI to see easily the Properties and Methods of used variables, and then use same/similar + make own for different.

#8

This procedure will do what is shown in your screenshots.

Sub Filter_Animation()
Const CRITERIA = "Animation"
Dim oSheets As Variant, oSourceSheet As Variant, oSheetResult1 As Variant, oSheetResult2 As Variant
Dim oCursor As Variant, oDataArray As Variant
Dim aSourceAddress As New com.sun.star.table.CellRangeAddress
Dim aCellResult1 As New com.sun.star.table.CellAddress
Dim aCellResult2 As New com.sun.star.table.CellAddress
Dim i As Long, j As Long 

	oSheets = ThisComponent.getSheets()
	oSourceSheet = oSheets.getByName("Sheet1")
	oCursor = oSourceSheet.createCursor()
	oCursor.gotoEndOfUsedArea(True)
	oDataArray = oSourceSheet.getCellRangeByPosition(4, 0, 4, oCursor.getRangeAddress().EndRow).getDataArray()
	aSourceAddress = oSourceSheet.getCellRangeByPosition(0, 0, 4, 0).getRangeAddress()
	
	If oSheets.hasByName("Result1") Then oSheets.removeByName("Result1")
	oSheets.insertNewByName("Result1", oSheets.getCount())
	oSheetResult1 = oSheets.getByName("Result1")

	If oSheets.hasByName("Result2") Then oSheets.removeByName("Result2")
	oSheets.insertNewByName("Result2", oSheets.getCount())
	oSheetResult2 = oSheets.getByName("Result2")

	aCellResult1 = oSheetResult1.getCellByPosition(0, 2).getCellAddress()
	aCellResult2 = oSheetResult2.getCellByPosition(0, 0).getCellAddress()
	For i = 2 To UBound(oDataArray)
		If Trim(oDataArray(i)(0)) = CRITERIA Then
			For j = 0 To 4
				aCellResult1.Row = J+2
				aSourceAddress.StartRow = i
				aSourceAddress.EndRow = i
				aSourceAddress.StartColumn = j
				aSourceAddress.EndColumn = j
				oSourceSheet.copyRange(aCellResult1, aSourceAddress)
			Next j
			aCellResult1.Column = aCellResult1.Column + 1
			
			aSourceAddress.StartColumn = 0
			aSourceAddress.EndColumn = 4
			oSourceSheet.copyRange(aCellResult2, aSourceAddress)
			aCellResult2.Row = aCellResult2.Row + 1
		EndIf 
	Next i
End Sub

Here, the RedDim Preserve mentioned in the title of the topic is never used.
I don’t know what your goal was when you posted this question and sent out private messages - did you really want to learn how to program in StarBASIC? Then you have chosen the wrong path.
Would you like someone to write this macro for you? Here it is, use it (but please don’t expect anyone to make changes to it sometime - we have much more interesting tasks).

2 Likes
#9

Hi JohnSUN , Thanks For your reply and Write Macro Code… In your Code works only Single Calc Document that is Source Data and Filtered Data based On Condition and Results will be placed in Same Calc Document in Two Sperate Sheets using " copyRange(target.CellAddress, Source.RangeAddress) "

Your Code and Source Format Will Apply to Results

Sub Filter_Animation()
Const CRITERIA = “Animation”
Dim oSheets As Variant, oSourceSheet As Variant, oSheetResult1 As Variant, oSheetResult2 As Variant
Dim oCursor As Variant, oDataArray As Variant
Dim aSourceAddress As New com.sun.star.table.CellRangeAddress
Dim aCellResult1 As New com.sun.star.table.CellAddress
Dim aCellResult2 As New com.sun.star.table.CellAddress
Dim i As Long, j As Long

oSheets = ThisComponent.getSheets()
oSourceSheet = oSheets.getByName("Sheet1")
oCursor = oSourceSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
oDataArray = oSourceSheet.getCellRangeByPosition(4, 0, 4, oCursor.getRangeAddress().EndRow).getDataArray()
aSourceAddress = oSourceSheet.getCellRangeByPosition(0, 0, 4, 0).getRangeAddress()

If oSheets.hasByName("Result1") Then oSheets.removeByName("Result1")
oSheets.insertNewByName("Result1", oSheets.getCount())
oSheetResult1 = oSheets.getByName("Result1")

If oSheets.hasByName("Result2") Then oSheets.removeByName("Result2")
oSheets.insertNewByName("Result2", oSheets.getCount())
oSheetResult2 = oSheets.getByName("Result2")

aCellResult1 = oSheetResult1.getCellByPosition(0, 2).getCellAddress()
aCellResult2 = oSheetResult2.getCellByPosition(0, 0).getCellAddress()
For i = 2 To UBound(oDataArray)
	If Trim(oDataArray(i)(0)) = CRITERIA Then
		For j = 0 To 4
			aCellResult1.Row = J+2
			aSourceAddress.StartRow = i
			aSourceAddress.EndRow = i
			aSourceAddress.StartColumn = j
			aSourceAddress.EndColumn = j
			oSourceSheet.copyRange(aCellResult1, aSourceAddress)
		Next j
		aCellResult1.Column = aCellResult1.Column + 1
		
		aSourceAddress.StartColumn = 0
		aSourceAddress.EndColumn = 4
		oSourceSheet.copyRange(aCellResult2, aSourceAddress)
		aCellResult2.Row = aCellResult2.Row + 1
	EndIf 
Next i

End Sub

and The Sceen Shots of your Code in Same Calc Document Using copyRange

image
image742×171 21.4 KB

image
image739×359 38.9 KB

image
image715×452 39.6 KB

image
image746×466 44.2 KB

1 ) Based On your Code … I Write The Macro Code For Two Different Calc Documents, that is Source Data in One Calc Document ( Doc1 ) and Destination or Results Will be Placed On Another Document ( Doc2 ) in Two Separate Sheets.

2 ) Based On your Code - I Slightly Modified, WithOut Using “CopyRange(target.CellAddress, SourceRangeAddress)”

Here is the Code - Two Different Calc Documents

Sub Filter_Action_6_TwoDifferentSheets()
Const CRITERIA = “Action” ’ or Use Dim Criteria As String : ’ Criteria = “Action”

		Dim oDoc As Object, oSheets As Object, oSourceSheet As Object
		Dim oDoc2 As Object, path As String, Args(), oSheets2 As Object, oSheetResult1 As Object, oSheetResult2 As Object
		Dim oCursor As Object, DataArray As Variant, i As Long, j As Long
		
		' oDoc1 -     1st Calc Document - Source Data
		oDoc = ThisComponent
		oSheets = oDoc.Sheets
		oSourceSheet = oSheets.getByName("Sheet1")
		
		oCursor = oSourceSheet.createCursor()
		oCursor.gotoEndOfUsedArea(True)

		DataArray = oSourceSheet.getCellRangeByPosition(4, 0, 4, oCursor.RangeAddress.EndRow).getDataArray()			
		
		' Doc2 -         2nd Calc Document - Desination for getting Data Based On Codition 
		path = ConvertToUrl("E:\Macros - VBA and STARBasic\StarBASIC\WiseOwl Tutorial\DestCalcDoc.ods")
		oDoc2 = StarDesktop.loadComponentFromURL(path, "default", 0, Args())	
		oSheets2 = oDoc2.Sheets
		oDestSheet = oSheets2.getByName("Sheet1")			
		
			If oSheets2.hasByName("Result1") Then oSheets2.removeByName("Result1")
			oSheets2.insertNewByName("Result1", oSheets2.Count)
			oSheetResult1 = oSheets2.getByName("Result1")
			
			If oSheets2.hasByName("Result2") Then oSheets2.removeByName("Result2")
			oSheets2.insertNewByName("Result2", oSheets2.Count)
			oSheetResult2 = oSheets2.getByName("Result2")
								    
		    ' Ouput Results, Which are going to in the Cell A3  (0,2)
			oSheetResult1.getCellByPosition(0, 2).getCellAddress()    'A3
			oSheetResult2.getCellByPosition(0, 2).getCellAddress()    'A3   ' (0, 0) A1
		
		Dim FilteredData(), PasteRange1 As Variant, PasteRange2 As Variant, oOutput As Variant
		
		For i = 2 To Ubound(DataArray)
			IF Trim(DataArray(i)(0)) = CRITERIA Then   ' Criteria Then
				For j = 0 To 4									
				     FilteredData() = oSourceSheet.getCellRangeByPosition(j,i,j,i).getDataArray()
				     Output = FilteredData
								
				     PasteRange2 = oSheetResult1.getCellByPosition(Column,2+j)
				     PasteRange2.setDataArray(oOutput)
							    
				     PasteRange = oSheetResult2.getCellByPosition(j,2+Row)
				     PasteRange.setDataArray(oOutput)									
				Next j 
			   Column = Column + 1
			 Row = Row + 1	   
			End IF		
		 Next i

End Sub

Here is the Macro Code For Same CalcDocument _ WithOut Using copyRange Method

Sub Filter_Action_7_SameSheet()
Const CRITERIA = “Action” ’ or Use Dim Criteria As String : Criteria = “Action”

		Dim oDoc As Object, oSheets As Object, oSourceSheet As Object, oSheetResult1 As Object, oSheetResult2 As Object
		Dim oCursor As Object, DataArray As Variant, i As Long, j As Long
		
		oDoc = ThisComponent : oSheets = oDoc.Sheets	
		oSourceSheet = oSheets.getByName("Sheet1")
		
		oCursor = oSourceSheet.createCursor()
		oCursor.gotoEndOfUsedArea(True)

		DataArray = oSourceSheet.getCellRangeByPosition(4, 0, 4, oCursor.RangeAddress.EndRow).getDataArray()
	
			If oSheets.hasByName("Result1") Then oSheets.removeByName("Result1")
			oSheets.insertNewByName("Result1", oSheets.Count)
			oSheetResult1 = oSheets.getByName("Result1")
			
			If oSheets.hasByName("Result2") Then oSheets.removeByName("Result2")
			oSheets.insertNewByName("Result2", oSheets.Count)
			oSheetResult2 = oSheets.getByName("Result2")
		
			Dim oCellResult1 As New com.sun.star.table.CellAddress	
		    Dim oCellResult2 As New com.sun.star.table.CellAddress
		    
		    ' Ouput Result, Which are going to in the Cell A3  (0,2)
			oCellResult1 = oSheetResult1.getCellByPosition(0, 2).getCellAddress()    'A3
			oCellResult2 = oSheetResult2.getCellByPosition(0, 2).getCellAddress()    'A3   ' (0, 0) A1	
		
		Dim FilteredData As Variant, oOutput As Variant, PasteRange1 As Variant, PasteRange2 As Variant 
		
		For i = 2 To Ubound(DataArray)
			IF Trim(DataArray(i)(0)) = CRITERIA Then 
				For j = 0 To 4
					FilteredData() = oSourceSheet.getCellRangeByPosition(j,i,j,i).getDataArray()

					oOutput = FilteredData
							
					PasteRange1 = oSheetResult1.getCellByPosition(Column, j+2)
					PasteRange1.setDataArray(oOutput)
							
					PasteRange2 = oSheetResult2.getCellByPosition(j, Row+2)
					PasteRange2.setDataArray(oOutput)	
				Next j 
				  Column = Column + 1
			   Row = Row + 1	 	  		   
			End IF		
		Next i

End Sub

Here Is the Source File and Screen Shots

Two Different Calc Documents

image
image742×171 21.4 KB

image
image739×359 38.9 KB

image

image

‘’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’
Same Calc Document

image
image742×171 21.4 KB

image
image739×359 38.9 KB

image

image

‘’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’

SourceFile

Part 25 - Arrays.ods (22.9 KB)

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