Duplicate data in excel sheet and filter the data according to the name

[kirubagari]

Hai experts,

How to duplicate the data from 1 excel sheet to another excel sheet 2.
Lets say

Name                   Voucher Value       Voucher Number     
lee                      300.00                58419-58421
meena                      300.00                58422-58424
Tan                        300.00                58425-58427 

I would like to filter the data accoring to the voucher number and the result is like this in excel

58419    lee      300.00    58419-58421
58420    lee      300.00    58419-58421
58421    lee      300.00    58419-58421
58422    meena    300.00    58422-58424
58423    meena    300.00    58422-58424
58424    meena    300.00    58422-58424
58425    Tan      300.00    58425-58427
58426    Tan      300.00    58425-58427
58427    Tan      300.00    58425-58427

I would like to filter the 1st sheet (input data) into second sheet in VBA MACRO.


The coding as below

Sub Duplicate
  Dim oDoc As Object, oSheet As Object, oCell As Object, oCell2 As Object, oCell3 As Object, oString As String
  Dim oCells As Object
  Dim oCursors As Object
  Dim aAddresss As Variant
 
  REM Define what sheet to used
  oDoc   =ThisComponent
  oSheet =oDoc.CurrentController.ActiveSheet
  oSheet2=oDoc.Sheets.getByIndex(1) '2nd Sheet
 
  REM Get the value of the LastUsedRow & LastUsedColumn
  oCells = oSheet.GetCellbyPosition(0, 0)
  oCursors = oSheet.createCursorByRange(oCells)
  oCursors.GotoEndOfUsedArea(True)
  aAddress = oCursors.RangeAddress
  LastUsedRow = aAddress.EndRow
  LastUsedColumn = aAddress.EndColumn
 
  'Row2Print=row printed row
  'l=last used row in Sheet2
 
 
  For i=0 to LastUsedRow
   'oCell2=ThisComponent.CurrentSelection.getCellAddress 'Currently Selected Cell
   oSelect=ThisComponent.CurrentSelection.getRangeAddress
   oString = oSheet.GetCellbyPosition(oSelect.StartColumn, i).getString() 'IMPORTANT (Need Revision)
   'getCellByPosition(Column,Row)
   oRight = Val(Right(oString,Len(oString)-InStr(1, oString, "-")))
   oLeft =  Val(Left(oString,Len(oString)-InStr(1, oString, "-")))
   Row2Print = oRight - oLeft
   oRangeOrg = oSheet.getCellRangeByName("A"&(i+1)&":O"&(i+1)).RangeAddress   ' copy range
 
    REM Begin Pasting the Value 
    For j=0 to Row2Print
   k=k+1
     oRangeCpy = oSheet2.getCellRangeByName("B"&k).RangeAddress ' insert range
     oCellCpy = oSheet2.getCellByPosition(oRangeCpy.StartColumn,oRangeCpy.StartRow).CellAddress ' insert position
     oSheet.CopyRange(oCellCpy, oRangeOrg) ' copy
    Next
 
   'oSheet2=oDoc.Sheets.getByIndex(1) '2nd Sheet 
   'oCells = oSheet2.GetCellbyPosition(0, 0)
   'oCursors = oSheet2.createCursorByRange(oCells)
   'oCursors.GotoEndOfUsedArea(True)
   'aAddress = oCursors.RangeAddress
   'LastUsedRow = aAddress.EndRow
   'LastUsedColumn = aAddress.EndColumn 
 
    For l=0 to Row2Print
     oCell4=oSheet2.getCellByPosition(0,m) 'A1
     oCell4.setString(oLeft)
     oLeft=oLeft+1
     m=m+1
    Next 
  Next i
  'oCell.NumberFormat=2   '23658.00
  'oCell.SetValue(12345)
  'oCell.SetString("oops")
  'oCell.setFormula("=FUNCTION()")
  'oCell.IsCellBackgroundTransparent = TRUE
  'oCell.CellBackColor = RGB(255,141,56)
End Sub
 
Function GetLastUsedRow(oSheets as Object) as Integer
Dim oCells As Object
Dim oCursors As Object
Dim aAddresss As Variant
 
oCells = oSheets.GetCellbyPosition(0, 0)
oCursors = oSheets.createCursorByRange(oCells)
oCursors.GotoEndOfUsedArea(True)
aAddresss = oCursors.RangeAddress
GetLastUsedRow = aAddresss.EndRow
End Function
 
Function GetLastUsedColumn(oSheet as Object) as Integer
  Dim oCell As Object
  Dim oCursor As Object
  Dim aAddress As Variant
  oCell = oSheet.GetCellbyPosition( 0, 0 )
  oCursor = oSheet.createCursorByRange(oCell)
  oCursor.GotoEndOfUsedArea(True)
  aAddress = oCursor.RangeAddress
  GetLastUsedColumn = aAddress.EndColumn
End Function
 
Sub SelRow()
  Dim oSheet
  Dim oRow
  oSheet = ThisComponent.getSheets().getByIndex(0)
  oRow = oSheet.getRows().getByIndex(2)
  ThisComponent.getCurrentController().select(oRow)
End Sub
 
Sub CopySpreadsheetRange
  oSheet1 = ThisComponent.Sheets.getByIndex(0)    ' sheet no 1, original
  oSheet2 = ThisComponent.Sheets.getByIndex(1)    ' sheet no 2
 
  oRangeOrg = oSheet1.getCellRangeByName("A1:C10").RangeAddress   ' copy range
  oRangeCpy = oSheet2.getCellRangeByName("A1:C10").RangeAddress   ' insert range
 
  oCellCpy = oSheet2.getCellByPosition(oRangeCpy.StartColumn,_
    oRangeCpy.StartRow).CellAddress ' insert position
 
  oSheet1.CopyRange(oCellCpy, oRangeOrg)                  ' copy
End Sub
'----------------------------------------------------------------------------------------
 
Function IsSpreadsheetDoc(oDoc) As Boolean
  Dim s$ : s$ = "com.sun.star.sheet.SpreadsheetDocument"
  IsSpreadsheetDoc = oDoc.SupportsService(s$)
End Function
 
Sub checking( )
  MsgBox IsSpreadsheetDoc(thisComponent)
End Sub
 
Sub ExampleGetValue
  Dim oDoc As Object, oSheet As Object, oCell As Object
  oDoc=ThisComponent
  oSheet=oDoc.Sheets.getByName("Sheet1")
  oCell=oSheet.getCellByposition(0,0) 'A1
  Rem a cell's contents can have one of the three following types:
  Print oCell.getValue()
  'Print oCell.getString()
  'Print oCell.getFormula()
End Sub
 
Sub SelectedCells 
  oSelect=ThisComponent.CurrentSelection.getRangeAddress
  oSelectColumn=ThisComponent.CurrentSelection.Columns
  oSelectRow=ThisComponent.CurrentSelection.Rows
 
  CountColumn=oSelectColumn.getCount
  CountRow=oSelectRow.getCount
 
  oSelectSC=oSelectColumn.getByIndex(0).getName
  oSelectEC=oSelectColumn.getByIndex(CountColumn-1).getName
 
  oSelectSR=oSelect.StartRow+1
  oSelectER=oSelect.EndRow+1
  NoCell=(CountColumn*CountRow)
 
  If CountColumn=1 AND CountRow=1 Then
    MsgBox("Cell " + oSelectSC + oSelectSR + chr(13) + "Cell No = " + NoCell,, "SelectedCells")
  Else
    MsgBox("Range(" + oSelectSC + oSelectSR + ":" + oSelectEC + oSelectER + ")" + chr(13) + "Cell No = " + NoCell,, "SelectedCells") 
  End If
End Sub
 
Sub Analize
  sSum="=SUM("+GetAddress+")"
  sAverage="=AVERAGE("+GetAddress+")"
  sMin="=MIN("+GetAddress+")"
  sMax="=MAX("+GetAddress+")"
  CellPos(7,6).setString(GetAddress)
  CellPos(7,8).setFormula(sSum)
  CellPos(7,8).NumberFormat=2
  CellPos(7,10).setFormula(sAverage)
  CellPos(7,10).NumberFormat=2
  CellPos(7,12).setFormula(sMin)
  CellPos(7,12).NumberFormat=2
  CellPos(7,14).setFormula(sMax)
  CellPos(7,14).NumberFormat=2
End sub
 
Function GetAddress  'selected cell(s)
  oSelect=ThisComponent.CurrentSelection.getRangeAddress
  oSelectColumn=ThisComponent.CurrentSelection.Columns
  oSelectRow=ThisComponent.CurrentSelection.Rows
 
  CountColumn=oSelectColumn.getCount
  CountRow=oSelectRow.getCount
 
  oSelectSC=oSelectColumn.getByIndex(0).getName
  oSelectEC=oSelectColumn.getByIndex(CountColumn-1).getName
 
  oSelectSR=oSelect.StartRow+1
  oSelectER=oSelect.EndRow+1
  NoCell=(CountColumn*CountRow)
 
  If CountColumn=1 AND CountRow=1 then  
    GetAddress=oSelectSC+oSelectSR  
  Else  
    GetAddress=oSelectSC+oSelectSR+":"+oSelectEC+oSelectER 
  End If
End Function
Function CellPos(lColumn As Long,lRow As Long)
  CellPos= ActiveSheet.getCellByPosition (lColumn,lRow)
End Function
Function ActiveSheet
  ActiveSheet=StarDesktop.CurrentComponent.CurrentController.ActiveSheet
End Function
Sub DeleteDbRange(sRangeName As String)    
  oRange=ThisComponent.DatabaseRanges
  oRange.removeByName (sRangeName)
End Sub 

KINDLY HELP ME SINCE THE CODING NOT WORKING INTEMETINLY..NEED HELP!!

[jimatqsi]

Wrong forum, I think you want the Excel forum.

Jim