VBCommons/excel/ex_Excel.bas

Attribute VB_Name = "ex_Excel"
'================ Äîïîëíèòåëüíûé ôóíêöèîíàë Excel =============
' Shared module version: 20220623
' Tested in:
' Depends on:
' Required reference: Scripting
Option Private Module
Option Explicit

Public Const XLUTIL_GRAPH_PADDING = 0.1
Public Const XL_DEFAULT_FIRST_ROW = 2
Public Const XL_INVALID_ROW = -1

Private Const XL_INFINITY_THRESHOLD = 255

Public Function XLFirstEmptyCell(iRange As Excel.Range) As Long
  Dim nItem&: nItem = 1
  Dim iCell As Excel.Range
  For Each iCell In iRange
    If iCell = vbNullString Then
      XLFirstEmptyCell = nItem
      Exit Function
    End If
    nItem = nItem + 1
  Next iCell
  
  XLFirstEmptyCell = -1
End Function

Public Function XLGetCallerCell() As Excel.Range
  On Error GoTo RETURN_NOTHING
  If TypeName(Application.Caller) = "Range" Then
    Set XLGetCallerCell = Application.Caller
    Exit Function
  End If
  
RETURN_NOTHING:
  On Error GoTo 0
  Set XLGetCallerCell = Nothing
End Function

Public Function XLWorksheetExists(sName$, iWhere As Excel.Workbook) As Boolean
  On Error Resume Next
  Dim iSheet As Excel.Worksheet
  Set iSheet = iWhere.Sheets(sName)
  On Error GoTo 0
  XLWorksheetExists = Not iSheet Is Nothing
End Function

Public Function XLShowAllData(target As Excel.Worksheet, Optional bKeepRows As Boolean = False, Optional bKeepColumns As Boolean = False)
  On Error Resume Next
  Call target.ShowAllData
  On Error GoTo 0
  
  If Not bKeepRows Then _
    target.Rows.EntireRow.Hidden = False
  If Not bKeepColumns Then _
    target.Columns.EntireColumn.Hidden = False
End Function

Public Function XLUpdateHyperlink(iCellAnchor As Excel.Range, sAddress$, Optional sSubAddress$ = "")
  Call iCellAnchor.Hyperlinks.Delete
  If sAddress = vbNullString Then _
    Exit Function
  Call iCellAnchor.Hyperlinks.Add(iCellAnchor, sAddress, sSubAddress)
End Function

Public Function AutoScaleGraphAxis(target As Excel.Chart, tValueRange As Excel.Range)
  Dim dMinValue As Double: dMinValue = WorksheetFunction.Min(tValueRange)
  Dim dMaxValue As Double: dMaxValue = WorksheetFunction.Max(tValueRange)
  If dMaxValue = dMinValue Then _
    Exit Function
  
  Dim dPrecision&: dPrecision = -(CLng(VBA.Log(dMaxValue - dMinValue) / VBA.Log(10#)) - 1)
  
  If VBA.Sgn(dMinValue) = VBA.Sgn(dMaxValue) Then
    dMinValue = dMinValue * IIf(dMinValue > 0, 1 - XLUTIL_GRAPH_PADDING, 1 + XLUTIL_GRAPH_PADDING)
    dMaxValue = dMaxValue * IIf(dMaxValue > 0, 1 + XLUTIL_GRAPH_PADDING, 1 - XLUTIL_GRAPH_PADDING)
    dMinValue = WorksheetFunction.Round(dMinValue, dPrecision)
    dMaxValue = WorksheetFunction.Round(dMaxValue, dPrecision)
  
    target.Axes(xlValue, xlPrimary).MinimumScale = dMinValue
    target.Axes(xlValue, xlPrimary).MaximumScale = dMaxValue
  End If
  
  If dPrecision > 0 Then
    target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0," & VBA.Replace(VBA.Space(dPrecision), " ", "0")
  Else
    target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0"
  End If
End Function

Public Function XLFindOrCreateID(sID$, nIdColumn&, target As Excel.Worksheet, _
                                  Optional nFirstRow& = XL_DEFAULT_FIRST_ROW) As Long
  ' Note: this function is precise but slow. Consider using Range.Find but beware of filtered cells being ignored
  Dim nRow&: nRow = nFirstRow
  Dim sTxt$
  Do
    sTxt = target.Cells(nRow, nIdColumn)
    If sTxt = vbNullString Then _
      Exit Do
    If sTxt = sID Then
      XLFindOrCreateID = nRow
      Exit Function
    End If
    nRow = nRow + 1
  Loop
  target.Cells(nRow, nIdColumn) = sID
  XLFindOrCreateID = nRow
End Function

Public Function XLBruteFindRow(sTarget$, nIdColumn&, wsWhere As Excel.Worksheet, _
                          Optional nFirstRow = XL_DEFAULT_FIRST_ROW) As Long
  XLBruteFindRow = XL_INVALID_ROW
  Dim nRow&: nRow = nFirstRow
  Dim sTxt$
  Do
    sTxt = wsWhere.Cells(nRow, nIdColumn)
    If sTxt = vbNullString Then
      Exit Function
    ElseIf sTxt = sTarget Then
      XLBruteFindRow = nRow
      Exit Function
    End If
    nRow = nRow + 1
  Loop
End Function

Public Function FlipColumnsOrder(target As Excel.Worksheet, nStart&, nFinish&)
  Dim nItem&
  For nItem = 0 To nFinish - nStart - 1 Step 1
    Call target.Columns(nStart).Cut
    Call target.Columns(nFinish - nItem + 1).Insert
  Next nItem
End Function

Public Function XLForEachNonEmptyCell(target As Excel.Range, oCallback As Object, sFuncName$)
  Dim aCell As Excel.Range
  Dim blankCount%: blankCount = 0
  For Each aCell In target
    If aCell = vbNullString Then
      blankCount = blankCount + 1
      If blankCount > XL_INFINITY_THRESHOLD Then _
        Exit Function
    Else
      blankCount = 0
      Call CallByName(oCallback, sFuncName, VbMethod, aCell)
    End If
  Next aCell
End Function