Inherit source number formatting, align headers to bottom, add CreateChartsFromSummary Sub

This commit is contained in:
2025-08-13 20:19:57 +00:00
parent 7b7694efd5
commit 600006b356
+165 -47
View File
@@ -1,3 +1,8 @@
REM ***** BASIC *****
Option Explicit
' ==== BuildWeatherSummaries ====
Sub BuildWeatherSummaries() Sub BuildWeatherSummaries()
Dim oDoc As Object, oSheets As Object, oSheet As Object, oSummary As Object, oRefSheet As Object Dim oDoc As Object, oSheets As Object, oSheet As Object, oSummary As Object, oRefSheet As Object
Dim sheetIndex As Long, col As Long, outCol As Long, row As Long Dim sheetIndex As Long, col As Long, outCol As Long, row As Long
@@ -9,14 +14,15 @@ Sub BuildWeatherSummaries()
categories = Array("Temp", "Wind", "Rel Humidity", "Avg Total Liquid Precipitation", "Rainy Days") categories = Array("Temp", "Wind", "Rel Humidity", "Avg Total Liquid Precipitation", "Rainy Days")
' UI rows: headers on row 23, data on rows 2637
headerRow = 23 headerRow = 23
startRow = 26 startRow = 26
endRow = 37 endRow = 37
oDoc = ThisComponent oDoc = ThisComponent
oSheets = oDoc.Sheets oSheets = oDoc.Sheets
' Get REF sheet ' Get REF sheet (for month abbreviations)
If Not SheetExists("REF") Then If Not SheetExists("REF") Then
MsgBox "Reference sheet 'REF' not found! Cannot pull month abbreviations." MsgBox "Reference sheet 'REF' not found! Cannot pull month abbreviations."
Exit Sub Exit Sub
@@ -37,14 +43,14 @@ Sub BuildWeatherSummaries()
For catIndex = LBound(categories) To UBound(categories) For catIndex = LBound(categories) To UBound(categories)
category = categories(catIndex) category = categories(catIndex)
' Write category title ' Title
oSummary.getCellByPosition(0, outRow).String = category & " Data Summary" oSummary.getCellByPosition(0, outRow).String = category & " Data Summary"
outRow = outRow + 1 outRow = outRow + 1
' Write month header ' Month header
oSummary.getCellByPosition(0, outRow).String = "Month" oSummary.getCellByPosition(0, outRow).String = "Month"
' Fill months (JanDec) from REF sheet, column A, rows 0 to 11 (adjust if needed) ' Fill months (JanDec) from REF sheet, column A, rows 0..11 (zero-based)
For row = 0 To 11 For row = 0 To 11
On Error Resume Next On Error Resume Next
oSummary.getCellByPosition(0, outRow + row + 1).String = oRefSheet.getCellByPosition(0, row).String oSummary.getCellByPosition(0, outRow + row + 1).String = oRefSheet.getCellByPosition(0, row).String
@@ -53,12 +59,13 @@ Sub BuildWeatherSummaries()
outCol = 1 outCol = 1
' Scan all sheets for matching name ' Scan all sheets whose name contains "monthly"
For sheetIndex = 0 To oSheets.Count - 1 For sheetIndex = 0 To oSheets.Count - 1
oSheet = oSheets.getByIndex(sheetIndex) oSheet = oSheets.getByIndex(sheetIndex)
If InStr(LCase(oSheet.Name), "monthly") > 0 Then If InStr(LCase(oSheet.Name), "monthly") > 0 Then
col = 0 col = 0
Do While col < 100 ' limit to 100 columns max to avoid infinite loop Do While col < 100 ' safety limit
' Read header text from the real header row (UI row 23 -> zero-based 22)
headerCell = oSheet.getCellByPosition(col, headerRow - 1) headerCell = oSheet.getCellByPosition(col, headerRow - 1)
header = Trim(headerCell.String) header = Trim(headerCell.String)
If header = "" Then Exit Do If header = "" Then Exit Do
@@ -67,12 +74,13 @@ Sub BuildWeatherSummaries()
If category = "Temp" Then If category = "Temp" Then
If InStr(headerLow, "avg") > 0 And InStr(headerLow, "temp") > 0 Then If InStr(headerLow, "avg") > 0 And InStr(headerLow, "temp") > 0 Then
Call CopyColumnData(oSheet, col, oSummary, outCol, outRow, startRow, endRow) ' copy using the TRUE header row, and data rows 26..37
CopyColumnData oSheet, col, headerRow, oSummary, outCol, outRow, startRow, endRow
outCol = outCol + 1 outCol = outCol + 1
End If End If
Else Else
If InStr(headerLow, LCase(category)) > 0 Then If InStr(headerLow, LCase(category)) > 0 Then
Call CopyColumnData(oSheet, col, oSummary, outCol, outRow, startRow, endRow) CopyColumnData oSheet, col, headerRow, oSummary, outCol, outRow, startRow, endRow
outCol = outCol + 1 outCol = outCol + 1
End If End If
End If End If
@@ -82,40 +90,61 @@ Sub BuildWeatherSummaries()
End If End If
Next sheetIndex Next sheetIndex
outRow = outRow + (endRow - startRow + 2) + 1 ' Skip past table with some space ' Move output pointer below this table (+1 for header row +12 months)
outRow = outRow + (endRow - startRow + 2) + 1
Next catIndex Next catIndex
MsgBox "Weather summaries built successfully." MsgBox "Weather summaries built successfully."
End Sub End Sub
' ==== Helpers ====
' Check if a sheet exists
Function SheetExists(sheetName As String) As Boolean Function SheetExists(sheetName As String) As Boolean
Dim oDoc As Object, oSheets As Object Dim oSheets As Object, oSheet As Object
oDoc = ThisComponent oSheets = ThisComponent.Sheets
oSheets = oDoc.Sheets On Error Resume Next
SheetExists = False oSheet = oSheets.getByName(sheetName)
Dim i As Integer SheetExists = (Err = 0)
For i = 0 To oSheets.Count - 1 On Error GoTo 0
If oSheets.getByIndex(i).Name = sheetName Then
SheetExists = True
Exit Function
End If
Next i
End Function End Function
Sub CopyColumnData(oSheet As Object, col As Long, oSummary As Object, outCol As Long, outRow As Long, startRow As Long, endRow As Long) ' Copy one source column (using the TRUE header row) into the summary table,
Dim row As Long, dataCell As Object, headerCell As Object, header As String ' preserving number formats for data cells.
' Now prefixes header with the source sheet name.
Sub CopyColumnData(srcSheet As Object, srcCol As Long, srcHeaderRow As Long, _
destSheet As Object, destCol As Long, destHeaderRow As Long, _
srcStartRow As Long, srcEndRow As Long)
headerCell = oSheet.getCellByPosition(col, 23 - 1) Dim r As Long
header = headerCell.String Dim srcCell As Object, destCell As Object
oSummary.getCellByPosition(outCol, outRow).String = oSheet.Name & " " & header Dim headerText As String
For row = startRow To endRow ' Copy header from the real header row and prefix with sheet name
dataCell = oSheet.getCellByPosition(col, row - 1) srcCell = srcSheet.getCellByPosition(srcCol, srcHeaderRow - 1)
oSummary.getCellByPosition(outCol, outRow + (row - startRow) + 1).Value = dataCell.Value headerText = srcSheet.Name & " " & srcCell.String
Next row destSheet.getCellByPosition(destCol, destHeaderRow).String = headerText
' Copy data rows (26..37) and preserve number format
For r = 0 To (srcEndRow - srcStartRow)
srcCell = srcSheet.getCellByPosition(srcCol, srcStartRow - 1 + r) ' zero-based conversion
destCell = destSheet.getCellByPosition(destCol, destHeaderRow + 1 + r)
' Preserve empties and text; copy numbers with format
If srcCell.Type = com.sun.star.table.CellContentType.EMPTY Then
destCell.String = ""
ElseIf srcCell.Type = com.sun.star.table.CellContentType.VALUE Then
destCell.Value = srcCell.Value
destCell.NumberFormat = srcCell.NumberFormat
Else
' text/formula-as-text
destCell.String = srcCell.String
destCell.NumberFormat = srcCell.NumberFormat
End If
Next r
End Sub End Sub
' ==== FormatSummaryTables ====
Sub FormatSummaryTables() Sub FormatSummaryTables()
Dim oDoc As Object, oSheet As Object Dim oDoc As Object, oSheet As Object
Dim outRow As Long Dim outRow As Long
@@ -125,7 +154,6 @@ Sub FormatSummaryTables()
Dim rangeStart As Long, rangeEnd As Long Dim rangeStart As Long, rangeEnd As Long
Dim categories() As String Dim categories() As String
Dim lastCol As Long Dim lastCol As Long
Dim cellContent As String
oDoc = ThisComponent oDoc = ThisComponent
oSheet = oDoc.Sheets.getByName("Summary") oSheet = oDoc.Sheets.getByName("Summary")
@@ -134,11 +162,11 @@ Sub FormatSummaryTables()
outRow = 0 outRow = 0
For i = LBound(categories) To UBound(categories) For i = LBound(categories) To UBound(categories)
' Title row (e.g. "Temp Data Summary") ' Title row
cell = oSheet.getCellByPosition(0, outRow) cell = oSheet.getCellByPosition(0, outRow)
cell.CharWeight = com.sun.star.awt.FontWeight.BOLD cell.CharWeight = com.sun.star.awt.FontWeight.BOLD
cell.CharHeight = 12 cell.CharHeight = 12
cell.CellBackColor = RGB(255, 255, 255) ' white cell.CellBackColor = RGB(255, 255, 255)
outRow = outRow + 1 outRow = outRow + 1
' Find last used column in header row ' Find last used column in header row
@@ -149,42 +177,132 @@ Sub FormatSummaryTables()
lastCol = j lastCol = j
Next j Next j
' Header row (months + data series names) ' Header row formatting
For j = 0 To lastCol For j = 0 To lastCol
cell = oSheet.getCellByPosition(j, outRow) cell = oSheet.getCellByPosition(j, outRow)
cell.CharWeight = com.sun.star.awt.FontWeight.BOLD cell.CharWeight = com.sun.star.awt.FontWeight.BOLD
cell.IsTextWrapped = True cell.IsTextWrapped = True
cell.CellBackColor = RGB(255, 173, 0) ' #FFAD00 orange cell.CellBackColor = RGB(255, 173, 0) ' #FFAD00 orange
cell.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER cell.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
cell.VertJustify = com.sun.star.table.CellVertJustify.CENTER cell.VertJustify = com.sun.star.table.CellVertJustify.BOTTOM ' <-- changed
Next j Next j
' Data rows (months + values) ' Data rows formatting
rangeStart = outRow + 1 rangeStart = outRow + 1
rangeEnd = outRow + 12 ' assuming 12 months data rows rangeEnd = outRow + 12 ' assuming 12 months data rows
For iRow = rangeStart To rangeEnd For iRow = rangeStart To rangeEnd
For j = 0 To lastCol For j = 0 To lastCol
cell = oSheet.getCellByPosition(j, iRow) cell = oSheet.getCellByPosition(j, iRow)
cellContent = Trim(cell.String) cell.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
' No rounding here — NumberFormat is inherited from source
' Only round numeric cells (leave month abbreviations and other text alone)
If IsNumeric(cellContent) And cellContent <> "" Then
cell.Value = Round(cell.Value, 1)
cell.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
Else
cell.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
End If
Next j Next j
Next iRow Next iRow
' Skip rows for next category
outRow = rangeEnd + 2 outRow = rangeEnd + 2
Next i Next i
MsgBox "Summary tables formatted." MsgBox "Summary tables formatted."
End Sub End Sub
Sub CreateChartsFromSummary()
Dim i As Integer
Dim iCat As Integer, iRow As Long
Dim oDoc As Object, oSheet As Object
Dim categories() As String
Dim categoryColors() As Long
Dim chartNames() As String
Dim oCharts As Object
Dim chartWidth As Long
Dim posX As Long, posY As Long
Dim outRow As Long
Dim dataStartRow As Long, dataEndRow As Long
Dim chartRangeAddress As Object
Dim chartObj As Object
Dim oChart As Object
Dim oDiagram As Object
oDoc = ThisComponent
oSheet = oDoc.Sheets.getByName("Summary")
oCharts = oSheet.Charts
' Configurable
categories = Array("Temp", "Wind", "Rel Humidity", "Avg Total Liquid Precipitation", "Rainy Days")
chartNames = Array("Temp Chart", "Wind Chart", "RH Chart", "Precip Chart", "Rainy Days Chart")
chartWidth = 6500 ' approx 6.5 inch * 1000 (adjust if needed)
posX = 1000
posY = 500
outRow = 0
For iCat = LBound(categories) To UBound(categories)
Dim category As String
category = categories(iCat)
' Find category table start row
Dim foundRow As Long
foundRow = -1
For iRow = outRow To oSheet.Rows.Count - 1
If InStr(oSheet.getCellByPosition(0, iRow).String, category & " Data Summary") > 0 Then
foundRow = iRow
Exit For
End If
Next iRow
If foundRow = -1 Then
MsgBox "Category " & category & " not found."
GoTo NextCategory
End If
Dim titleRow As Long: titleRow = foundRow
Dim headerRow As Long: headerRow = titleRow + 1
dataStartRow = headerRow + 1
dataEndRow = dataStartRow + 11 ' 12 months assumed
Dim lastCol As Long: lastCol = 0
For i = 0 To oSheet.Columns.Count - 1
If Trim(oSheet.getCellByPosition(i, headerRow).String) = "" Then Exit For
lastCol = i
Next i
If lastCol <= 0 Then
MsgBox "No data columns found for " & category
GoTo NextCategory
End If
chartRangeAddress = oSheet.getCellRangeByPosition(0, headerRow, lastCol, dataEndRow).getRangeAddress()
' Remove existing chart if present
If oCharts.hasByName(chartNames(iCat)) Then
oCharts.removeByName(chartNames(iCat))
End If
Dim chartPos As New com.sun.star.awt.Rectangle
chartPos.X = posX
chartPos.Y = posY + iCat * 7000
chartPos.Width = chartWidth
chartPos.Height = 20320
oCharts.addNewByName(chartNames(iCat), chartPos, Array(chartRangeAddress), True, True)
chartObj = oCharts.getByName(chartNames(iCat))
oChart = chartObj.EmbeddedObject
' Set chart type to line diagram
oDiagram = oChart.createInstance("com.sun.star.chart.LineDiagram")
oChart.setDiagram(oDiagram)
oChart.HasMainTitle = True
oChart.Title.String = category & " Comparison"
oChart.HasLegend = True
oChart.setPropertyValue("LegendPosition", com.sun.star.chart.ChartLegendPosition.BOTTOM)
outRow = dataEndRow + 2
NextCategory:
Next iCat
MsgBox "Charts created."
End Sub
Function Round(num, Optional decimals) Function Round(num, Optional decimals)
Dim factor Dim factor
If IsMissing(decimals) Then If IsMissing(decimals) Then