Using "Do Util and IF Condition" copy the data and paste in respective Sheetnames (FilmRating) one by one,Each Sheets repectively in VBA and get results. But, In LibreOffice i Can't get the results. Where i made mistake?

English
, , ,
#1

Hello Friends,
Can any one help me ?.
i can get results While running VBA macro in Excel. Using “Do Util and IF Condition” and copy the data and paste in respective Sheetnames (FilmRating) one by one.
But, In LibreOffice i Can’t get the results, Like VBA does.
I tried both method ->>>> 1 ) setDataArray() and getDataArray()
2) copyRange(cellAddress, RangeAddress)

Can any one tell me where i made mistake? and how to get the results in BASIC macros in LibreOffice
Both method 1) & 2) I want Proper Code.
I have attached the Source Files. Both->>> Excel and Calc Spreadsheets

Source Data

image
image917×704 175 KB

Excel File

Do Until and Do While Loops.xlsx (13.9 KB)

Excel Macro Code

Sub ProfessionalWay_SeperatingListWith_DoLoop()
    Dim FilmLength As Integer
    Dim FilmRating As String
    
    Application.ScreenUpdating = False
    
    Worksheets("Sheet1").Activate
    Range("A3").Select

    Do Until ActiveCell.Value = ""
             
        FilmLength = ActiveCell.Offset(0, 3).Value
        
        If FilmLength < 100 Then
            FilmRating = "Short"
        ElseIf FilmLength < 120 Then
            FilmRating = "Medium"
        ElseIf FilmLength < 150 Then
            FilmRating = "Long"
        Else
            FilmRating = "Epic"
        End If
        
        Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
        Worksheets(FilmRating).Select
        ActiveCell.PasteSpecial
        ActiveCell.Offset(1, 0).Select
        
        Worksheets("Sheet1").Activate
        ActiveCell.Offset(1, 0).Select
    Loop
        
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

Screen Shots Of _Excel Macro Result

image
image774×354 85.3 KB

image
image782×353 87 KB

image
![image|690x330](upload://bHDzu0vSjclmGH69GwsCORGhVQP.png

LibreOffice Calc Source Data

image
image727×513 46.6 KB

Calc Spreadsheet Files

Part 15 - Do Until and Do While Loops_CopyRange.ods (15.5 KB)

Part 15 - Do Until and Do While Loops_CopyRange.ods (15.5 KB)

LibreOffice BASIC Macro Code _Method1_Using getDataArray & setDataArray

Sub SeperatingListWith_DoLoop_set_get_DataArra()
	 Dim Doc As Object, oSheets As Object, Sheet As Object
	 Dim Cell As Object, oCell As Object, CopyRange As Object, PasteRange As Object
	 Dim CopyData()
	 Dim i As Integer
	 
	    Dim FilmLength As Integer
	    Dim FilmRating As String
	    
	    Doc = ThisComponent : oSheets = Doc.Sheets(0)
	    Doc.CurrentController.setActiveSheet(oSheets)
	    Cell = oSheets.getCellByPosition(0, 2)  ' A3
	    
	    i = 0
	    Do Until Cell.Type = com.sun.star.table.CellContentType.EMPTY    ' Cell.getType(com.sun.star.table.CellContentType.EMPTY)
	    FilmLength = oSheets.getCellByPosition(3, i+2).getValue()
	        
	        If FilmLength < 100 Then
	            FilmRating = "Short"
	        ElseIf FilmLength < 120 Then
	            FilmRating = "Medium"
	        ElseIf FilmLength < 150 Then
	            FilmRating = "Long"
	        Else
	            FilmRating = "Epic"
	        End If
	        
	        CopyRange = oSheets.getCellRangeByPosition(0, i+2, 3, i+2)
	        CopyData = CopyRange.getDataArray()
	        
	        Sheet = Doc.getSheets().getByName(FilmRating)
	        Doc.CurrentController.setActiveSheet(Sheet)
	        PasteRange = Sheet.getCellRangeByPosition(0, i, 3, i)
	        PasteRange.setDataArray(CopyData)
	
	        Doc.CurrentController.setActiveSheet(oSheets)
	        Cell = oSheets.getCellByPosition(0, 2+i)
	        i = i + 1
	    Loop
End Sub

Macro Result Screen Shots

image
image
image
image

LibreOffice BASIC Macro _Using_copyRange()_Method 2

Sub SeperatingListWith_DoLoop_copyRange()
 Dim Doc As Object, oSheets As Object, Sheet As Object
 Dim Cell As Object, oCellAddress As Object, CopyRange As Object, PasteRange As Object
 Dim CopyData()
 Dim i As Integer
 
    Dim FilmLength As Integer
    Dim FilmRating As String
    
    Doc = ThisComponent : oSheets = Doc.Sheets(0)
    Doc.CurrentController.setActiveSheet(oSheets)
    Cell = oSheets.getCellByPosition(0, 2)  ' A3
    
    i = 0
    Do Until Cell.Type = com.sun.star.table.CellContentType.EMPTY    ' Cell.getType(com.sun.star.table.CellContentType.EMPTY)
    FilmLength = oSheets.getCellByPosition(3, i+2).getValue()
        
        If FilmLength < 100 Then
            FilmRating = "Short"
        ElseIf FilmLength < 120 Then
            FilmRating = "Medium"
        ElseIf FilmLength < 150 Then
            FilmRating = "Long"
        Else
            FilmRating = "Epic"
        End If
        
        CopyRange = oSheets.getCellRangeByPosition(0, i+2, 3, i+2).getRangeAddress()
        
        Sheet = Doc.Sheets.getByName(FilmRating)
        Doc.CurrentController.setActiveSheet(Sheet)
        oCellAddress = Sheet.getCellByPosition(0,0).getCellAddress()
 		
			CopyRange.StartColumn = 0   
		    CopyRange.EndColumn = 3
		    oSheets.copyRange(oCellAddress, CopyRange)
					  		   
			oCellAddress.Row = oCellAddress.Row + 1		  		

        Doc.CurrentController.setActiveSheet(oSheets)
        Cell = oSheets.getCellByPosition(0, 2+i)
        i = i + 1
    Loop
 		
End Sub

Macro Result _Screen Shots

image
image
image
image

#4

My uncle used to say, “If one door closes, another door is sure to open somewhere.” He was a great philosopher, but a poor furniture maker.

Your VBA macro stopped working and you treated it as a problem. Be a little philosophical, treat it like a closed door - move away from your task and look at it a little from afar. Perhaps this will help you understand that the original macro was bad and should have been abandoned a long time ago? Perhaps the problem you tried to solve by copying or duplicating data has a simpler solution? In fact, the problem that the old macro tried to solve (and even partially solved, I don’t argue) was to select a group of rows from a large list of data based on a certain criterion. There is a special term for this task - “filtration”. And for filtering in Calc there are at least three different filters.

This means that you do not need to duplicate data from Sheet1 to other sheets, you just need to select a filter that is suitable for your task.

Please try to look at the problem from different angles before you undertake to solve it. The longer a person thinks about a task, the faster and better the computer copes with the task.

#5

Yes, Filter is great solution, But, as i already mentioned i am learning Calc Macros… So imitating the code or alternative way of getting code … will learn quickly.
And Most of the Credits goes to You … I learned so much from your answers. Thanks.

#6

Oh, are these mutually exclusive things? Perhaps you did not move far enough from the task and did not see the whole picture?

Okay, I’ll do it for you one more time.
We agreed that a filter was the right tool for this task. We want to get a macro.
Open the Basic IDE and start writing:

Option Explicit 

Sub SplitDataIntoSheets()
Dim oSheets As Variant	''' All sheets of this spreadsheet '''
Dim oSheet As Variant	''' Main sheet with source data '''
Dim oCursor As Variant	''' Find UsedRange '''
Dim FilterDescriptor As Variant
''' An array of two elements, each of which is a structure of a special format.  '''
''' See description in https://api.libreoffice.org/docs/idl/ref/structcom_1_1sun_1_1star_1_1sheet_1_1TableFilterField.html '''
Dim oFilterFields(1) As New com.sun.star.sheet.TableFilterField 
''' Using this structure we will show the filter where to place the next filtering result '''
Dim aCellAddress As New com.sun.star.table.CellAddress	

	oSheets = ThisComponent.getSheets()	
	oSheet = oSheets.getByName("Sheet1")
	oCursor = oSheet.createCursor()
	oCursor.gotoEndOfUsedArea(True)
''' Since the real table starts on the second row, let's move one row down '''
	oCursor.gotoOffset(0, 1)

	aCellAddress = oCursor.getCellByPosition(0, 0).getCellAddress()
''' Now aCellAddress points to cell A2 of Sheet1. We just need to change the aCellAddress.Sheet to get cell A2 of any other sheet '''

	FilterDescriptor = oCursor.createFilterDescriptor(True)
	FilterDescriptor.CopyOutputData = True
	FilterDescriptor.ContainsHeader = True
	
''' Now you will need to write quite a lot to formalize the condition If FilmLength < 100 Then FilmRating = "Short" '''
	oFilterFields(0).Connection = com.sun.star.sheet.FilterConnection.AND
	oFilterFields(0).Field = 3
	oFilterFields(0).IsNumeric = True
	oFilterFields(0).Operator = com.sun.star.sheet.FilterOperator.LESS
	oFilterFields(0).NumericValue = 100
	FilterDescriptor.setFilterFields(oFilterFields)
''' Yes, now it took 6 lines of code to write "the numeric value in the fourth column is less than 100" '''
''' It will be easier later '''
	aCellAddress.Sheet = 1	
	FilterDescriptor.OutputPosition = aCellAddress ''' Now the target cell is Short.$A$2 '''
	oCursor.Filter(FilterDescriptor)	''' One line of code and a quarter of the work is done - the necessary rows are already in the Short sheet '''
''' Let's change only a few of the already set values to get the condition ""the numeric value in the fourth column is GREATER_EQUAL than 150" '''
''' and assign the last sheet of Epic for output '''
	oFilterFields(0).Operator = com.sun.star.sheet.FilterOperator.GREATER_EQUAL
	oFilterFields(0).NumericValue = 150
	FilterDescriptor.setFilterFields(oFilterFields)
	aCellAddress.Sheet = 4
	FilterDescriptor.OutputPosition = aCellAddress
	oCursor.Filter(FilterDescriptor)	''' Half the work is done '''
''' For the Medium and Long sheets, two conditions are needed to select the values "between" '''
	oFilterFields(0).Operator = com.sun.star.sheet.FilterOperator.LESS
	oFilterFields(1).Connection = com.sun.star.sheet.FilterConnection.AND
	oFilterFields(1).Field = 3
	oFilterFields(1).IsNumeric = True
	oFilterFields(1).Operator = com.sun.star.sheet.FilterOperator.GREATER_EQUAL
	oFilterFields(1).NumericValue = 120
	FilterDescriptor.setFilterFields(oFilterFields)
	aCellAddress.Sheet = 3
	FilterDescriptor.OutputPosition = aCellAddress
	oCursor.Filter(FilterDescriptor) ''' Great, just a little left '''
''' The last condition differs from the previous one only in the values '''
	oFilterFields(0).NumericValue = 120
	oFilterFields(1).NumericValue = 100
	FilterDescriptor.setFilterFields(oFilterFields)
	aCellAddress.Sheet = 2
	FilterDescriptor.OutputPosition = aCellAddress
	oCursor.Filter(FilterDescriptor) ''' All work is done without cycles - quickly and accurately '''
End Sub

Don’t be confused by the sequence of filling out the sheets - the first, then the last, then the penultimate, finally the third. You are the author, you are the artist, you yourself draw this sequence. And if it’s easier for you to write the code by rearranging the sheets, then no one can forbid you from doing this.

So, problem solved - no loops, no copying cells or ranges, no switching between sheets using .Sheets.getByName(FilmRating). It was enough to examine the task and the available tools from all sides and think a little

1 Like
#2

Hello @sv.thiyagarajan,

In the Excel macro, after it has copied a film:
ActiveCell.PasteSpecial
It moves to the cell below:
ActiveCell.Offset(1, 0).Select
This is equivalent of maintaining, for each sheet, a cursor at the position of the first empty cell.

The LO macro uses the same index i to define the row where to copy the data. This is incorrect. You should maintain for each sheet an index. Try this:

        idx_Short = 0
        idx_Medium = 0
        idx_Long = 0
        idx_Epic = 0
        Do Until Cell.Type = com.sun.star.table.CellContentType.EMPTY    
    	    FilmLength = oSheets.getCellByPosition(3, i+2).getValue()

            If FilmLength < 100 Then
	            FilmRating = "Short"
                j = idx_Short
                idx_Short = idx_Short + 1
	        ElseIf FilmLength < 120 Then
	            FilmRating = "Medium"
                j = idx_Medium
                idx_Medium = idx_Medium + 1
	        ElseIf FilmLength < 150 Then
	            FilmRating = "Long"
                j = idx_Long
                idx_Long = idx_Long + 1
	        Else
	            FilmRating = "Epic"
                j = idx_Epic
                idx_Epic = idx_Epic + 1
	        End If

Then modify the code to copy the range by using the variable j as the destination row (instead of i). i stays as the index for the input sheet.

I have not tried it, so it is well possible that I have made a typo or a logic error!!!

1 Like
#3

Hallo

from collections import defaultdict
from com.sun.star.uno import RuntimeException

def filter_by_lengt(*_):
    doc = XSCRIPTCONTEXT.getDocument()
    sheets = doc.Sheets
    source = sheets["Sheet1"]
    header = source["A2:D2"].DataArray[0]
    categories = defaultdict(list)
    for category in "Short Medium Long Epic".split():
        categories[category].append(header)
        try:
            sheets.insertNewByName(category, sheets.Count)
        except RuntimeException:
            sheets[category].clearContents(15)
        
    cursor = source.createCursorByRange(source["A3"])
    cursor.gotoEndOfUsedArea(True)
    for row in cursor.DataArray:
        if row[-1] < 100:
            categories['Short'].append(row)
        elif row[-1] < 120:
            categories['Medium'].append(row)
        elif row[-1] < 150:
            categories['Long'].append(row)
        else:
            categories['Epic'].append(row)
    for name, data in categories.items():
        cursor = sheets[name].createCursorByRange(sheets[name]["A1"])
        cursor.collapseToSize(len(data[0]), len(data))
        cursor.DataArray = data
1 Like

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