Add BuildWeatherSummaries

This commit is contained in:
2025-08-13 18:25:33 +00:00
commit 750b40e157

117
BuildWeatherSummaries Normal file
View File

@@ -0,0 +1,117 @@
Sub BuildWeatherSummaries()
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 category As String, header As String, headerLow As String
Dim categories() As String
Dim startRow As Long, endRow As Long, headerRow As Long
Dim headerCell As Object
Dim outRow As Long
categories = Array("Temp", "Wind", "Rel Humidity", "Avg Total Liquid Precipitation", "Rainy Days")
headerRow = 23
startRow = 26
endRow = 37
oDoc = ThisComponent
oSheets = oDoc.Sheets
' Get REF sheet
If Not SheetExists("REF") Then
MsgBox "Reference sheet 'REF' not found! Cannot pull month abbreviations."
Exit Sub
End If
oRefSheet = oSheets.getByName("REF")
' Create or clear the Summary sheet
If Not SheetExists("Summary") Then
oSummary = oSheets.createByName("Summary", oSheets.Count)
oSheets.insertByName("Summary", oSummary)
End If
oSummary = oSheets.getByName("Summary")
oSummary.clearContents(1023) ' clear all
outRow = 0
Dim catIndex As Long
For catIndex = LBound(categories) To UBound(categories)
category = categories(catIndex)
' Write category title
oSummary.getCellByPosition(0, outRow).String = category & " Data Summary"
outRow = outRow + 1
' Write month header
oSummary.getCellByPosition(0, outRow).String = "Month"
' Fill months (JanDec) from REF sheet, column A, rows 0 to 11 (adjust if needed)
For row = 0 To 11
On Error Resume Next
oSummary.getCellByPosition(0, outRow + row + 1).String = oRefSheet.getCellByPosition(0, row).String
On Error GoTo 0
Next row
outCol = 1
' Scan all sheets for matching name
For sheetIndex = 0 To oSheets.Count - 1
oSheet = oSheets.getByIndex(sheetIndex)
If InStr(LCase(oSheet.Name), "monthly") > 0 Then
col = 0
Do While col < 100 ' limit to 100 columns max to avoid infinite loop
headerCell = oSheet.getCellByPosition(col, headerRow - 1)
header = Trim(headerCell.String)
If header = "" Then Exit Do
headerLow = LCase(header)
If category = "Temp" Then
If InStr(headerLow, "avg") > 0 And InStr(headerLow, "temp") > 0 Then
Call CopyColumnData(oSheet, col, oSummary, outCol, outRow, startRow, endRow)
outCol = outCol + 1
End If
Else
If InStr(headerLow, LCase(category)) > 0 Then
Call CopyColumnData(oSheet, col, oSummary, outCol, outRow, startRow, endRow)
outCol = outCol + 1
End If
End If
col = col + 1
Loop
End If
Next sheetIndex
outRow = outRow + (endRow - startRow + 2) + 1 ' Skip past table with some space
Next catIndex
MsgBox "Weather summaries built successfully."
End Sub
Function SheetExists(sheetName As String) As Boolean
Dim oDoc As Object, oSheets As Object
oDoc = ThisComponent
oSheets = oDoc.Sheets
SheetExists = False
Dim i As Integer
For i = 0 To oSheets.Count - 1
If oSheets.getByIndex(i).Name = sheetName Then
SheetExists = True
Exit Function
End If
Next i
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)
Dim row As Long, dataCell As Object, headerCell As Object, header As String
headerCell = oSheet.getCellByPosition(col, 23 - 1)
header = headerCell.String
oSummary.getCellByPosition(outCol, outRow).String = oSheet.Name & " " & header
For row = startRow To endRow
dataCell = oSheet.getCellByPosition(col, row - 1)
oSummary.getCellByPosition(outCol, outRow + (row - startRow) + 1).Value = dataCell.Value
Next row
End Sub