Could someone please help fix this problem
Here is the code:
Code: Select all
ption Explicit ' All variables are declared explicitly in terms of "Dim".
Option Base 0 ' Each array indexing starts at zero
REM First, we list all auxiliary procedures
REM Collect data to temporary struct
REM key - array of some values on sheet "Jan"
REM (Are you sure that you want separate sheet for each month?)
REM Array key containe: string from your column H (category)
REM and other data for sheet Kontokort (Dato, Bilag nr., Tekst, Beløb)
REM aData - "indexed" array (each element containe "Kontonummer og navn"
REM and array with other data)
Sub AddToStruct(key As Variant, aData As Variant)
Dim l&, r&, m&, N&, i&
l=LBound(aData)
r=UBound(aData)+1
N=r
While (l<r) ' "binary search" - it is very fast in the sorted array
m=l+Int((r-l)/2)
If aData(m)(0)<key(0) Then
l=m+1
Else
r=m
EndIf
Wend
If r=N Then ' Not present - add to end of the temporary struct
ReDim Preserve aData(0 To N)
aData(N) = Array(key(0),Array(Array(key(1),key(2),key(3),key(4))))
ElseIf aData(r)(0)=key(0) Then ' is present - add new value
AppendToArray(aData(r)(1), Array(key(1),key(2),key(3),key(4)))
Else ' Insert in the middle of the structure
ReDim Preserve aData(0 To N)
For i = N-1 To r Step -1
aData(i+1)=aData(i)
Next i
aData(r) = Array(key(0),Array(Array(key(1),key(2),key(3),key(4))))
EndIf
End Sub
REM It's not my procedure - this is "Listing 63. Append data to an array"
REM from "AndrewBase.odt" (http://www.pitonyak.org/database/)
REM
REM Here x is array {Dato, Bilag nr., Tekst, Beløb}
Sub AppendToArray(oData As Variant, ByVal x As Variant)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
REM This function is not mine too. This is from the standard library Tools.
REM But there this function defined as Integer.
REM This means that if one day the number of rows in Jan exceeds 65,535 then macro will "break down".
REM (https://bugs.documentfoundation.org/show_bug.cgi?id=50846)
REM So, I just copy it here and change type of result
Function GetLastUsedRow(oSheet as Object) As Long
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
GetLastUsedRow = aAddress.EndRow
End Function
REM Write collected data to target range
REM (Find column with Kontonummer from oKontonummer(0))
REM Return True (Successful) or False (Kontonummer not found)
REM For example, you add an item to the list "konti",
REM but forgot to add it to the sheet "Kontokort"
Function insertToTargetRangeByKontonummer(oKontonummer As Variant, aKontonummers As Variant, oSheet As Variant) As Boolean
Dim i&
GlobalScope.BasicLibraries.LoadLibrary("Tools") ' That library, from which we took a function GetLastUsedRow
i = IndexInArray(oKontonummer(0), aKontonummers) ' This cycle we could write ourselves. But why?
If i < 0 Then
insertToTargetRangeByKontonummer = False
Else
oSheet.getCellRangeByPosition(i, 7, i+3, 7+UBound(oKontonummer(1))).setDataArray(oKontonummer(1))
insertToTargetRangeByKontonummer = True
EndIf
End Function
REM And now - main sub of our project ("core")
REM Parameters is names of sheets - first param is list separated with comma
Sub sortAndFillKontokort(sSource As String, sTarget As String)
Dim oSheets As Variant ' All sheets of workbook
Dim aSource As Variant ' Array of sheetnames
Dim inSheet As Variant ' Source sheet
Dim outSheet As Variant ' Target sheet
Dim aRangeAddress As New com.sun.star.table.CellRangeAddress
Dim oCellRangeByPosition As Variant
Dim oDataArray As Variant ' Data from input sheet (array rows of array cells)
Dim oData As Variant ' Single row (array of cells)
Dim aTemp As Variant ' Temporary collection
Dim oCursor As Variant
Dim oHeader As Variant ' Row with titles from output sheet
Dim nStartColumn As Long
Dim nEndColumn As Long
Dim nStartRow As Long
Dim nEndRow As Long
Dim i&, s&
Dim errMsg As String
oSheets = ThisComponent.getSheets()
If not oSheets.hasByName(sTarget) Then Exit Sub
aSource = Split(sSource, ",")
aTemp = Array()
For s = LBound(aSource) To UBound(aSource)
If oSheets.hasByName(Trim(aSource(s))) Then
inSheet = oSheets.getByName(Trim(aSource(s)))
nEndRow = GetLastUsedRow(inSheet)
If nEndRow > 15 Then ' Header of table in 15th row - no data, nothing to do
REM Get data. From column B (Dato:) to column H (Kontonr.:), from first datarow (16th) to last row
oDataArray = inSheet.getCellRangeByPosition(1, 15, 7, nEndRow).getDataArray()
For i = LBound(oDataArray) To UBound(oDataArray)
oData = oDataArray(i)
If Trim(oData(6)) > "" Then ' Skip empty rows
REM Send to sub all fields:Kontonr.:Dato: Bilag nr.: Tekst: Beløb:
AddToStruct(Array(oData(6), oData(0), oData(1), oData(2), oData(4)), aTemp)
EndIf
Next i
EndIf
EndIf
Next s
If LBound(aTemp)>UBound(aTemp) Then Exit Sub ' No data?
outSheet = oSheets.getByName(sTarget)
oCursor = outSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
aRangeAddress = oCursor.getRangeAddress()
nEndRow = aRangeAddress.EndRow ' Same as GetLastUsedRow(outSheet). But we need EndColumn too
If nEndRow < 4 Then Exit Sub ' Where is row with Header of table?!! Wrong format of sheet
nEndColumn = aRangeAddress.EndColumn
REM Clear numbers, dates and texts, but leave formats and others
REM Clear to to last row (maybe new data is shotrtly)
If nEndRow>6 Then outSheet.getCellRangeByPosition(0, 7, nEndColumn, nEndRow).clearContents(7)
oHeader = outSheet.getCellRangeByPosition(0, 4, nEndColumn, 4).getDataArray()
REM Array of arrays? No! We need single row:
oHeader = oHeader(0)
REM OK, let's go!
REM And paste results to place:
errMsg = "Sorry, but some items not found:"
outSheet.unprotect("OUR_PWD")
For i = LBound(aTemp) To UBound(aTemp)
If Not insertToTargetRangeByKontonummer(aTemp(i), oHeader, outSheet) Then
errMsg = errMsg + Chr(10) + aTemp(i)(0)
EndIf
Next i
outSheet.protect("OUR_PWD")
If Len(errMsg) > 32 Then MsgBox(errMsg,48,"Detected error(s) in source data")
End Sub
REM And so? Just call "core" with parameters
REM I put this subroutine to button
REM You can set it as listener for "content changed on Jan" or "sheet Kontokort activate" or... or something
Sub runCoreWithDefaultParams()
sortAndFillKontokort("Jan,Feb,Mar,Apr,Maj,Jun,Jul,Aug,Sep,Okt,Nov,Dec","Kontokort")
End Sub