Option Explicit

' Стандартный Trim не обрезает vbCr :(, a BEX при горизонтальной
' развертке добавляет по переводу строки на уровень иерархии

Function RealTrim(Val As String)
    Dim b As Integer
    Dim e As Integer
   
    If Val = "" Then
        RealTrim = ""
        Exit Function
    End If
   
    b = 1
    e = Len(Val)
   
    Do While Mid(Val, b, 1) <= " " And b <= e
        b = b + 1
    Loop
   
    Do While Mid(Val, e, 1) <= " " And e > b
        e = e - 1
    Loop
   
    RealTrim = Mid(Val, b, e - b + 1)
   
End Function

Sub SAPBEXonRefresh(queryID As String, resultArea As Range)
   
    ' Далее нас интересует только один запрос
    If queryID <> "SAPBEXq0003" Then Exit Sub
   
    ' Текст в заголовке ключа
    Const KeyMark = "_Ключ_"
    ' Текст в заголовке атрибута, который заменяем
    '(0TXTLG использовать нельзя, т.к. заголово пуст)
    Const TextMark = "_Описание_"
   
    Dim KeyColCell As Range
    Dim TextColCell As Range
    Dim KeysRange As Range
    Dim TextsRange As Range
    Dim FindCount As Integer
    Dim CurCell As Range
   
    ' Находим значение каждой колонки (или строки)
    Set KeyColCell = resultArea.Find(KeyMark, LookIn:=xlValues, LookAt:=xlWhole)
    If KeyColCell Is Nothing Then
        Debug.Print "Развертка """ & KeyMark & """ не найдена"
        Exit Sub
    End If
   
    Set TextColCell = resultArea.Find(TextMark, LookIn:=xlValues, LookAt:=xlWhole)
    If TextColCell Is Nothing Then
        Debug.Print "Развертка """ & TextMark & """ не найдена"
        Exit Sub
    End If
   
    If TextColCell.Column = KeyColCell.Column Then
        'Axis = "X"
        Set KeysRange = Intersect(resultArea, KeyColCell.EntireRow)
        Set TextsRange = Intersect(resultArea, TextColCell.EntireRow)
    Else
        If TextColCell.Row = KeyColCell.Row Then
            'Axis = "Y"
            Set KeysRange = Intersect(resultArea, KeyColCell.EntireColumn)
            Set TextsRange = Intersect(resultArea, TextColCell.EntireColumn)
        Else
            Debug.Print "Неизвестное состояние отчета"
            Exit Sub
        End If
    End If
   
    Dim SrcKeysRange As Range
    Dim KeyCell As Range
    Set SrcKeysRange = Names("SAPBEXqueries!SAPBEXq0002").RefersToRange.Columns(1)
   
    Dim CO As Integer
    Dim RO As Integer
   
    CO = KeysRange.Cells(1, 1).Column - 1
    RO = KeysRange.Cells(1, 1).Row - 1
   
    Dim Text As String
    Dim i As Integer
   
    For Each CurCell In KeysRange
       
        Set KeyCell = SrcKeysRange.Find(RealTrim(CurCell.Value), LookIn:=xlValues, LookAt:=xlWhole)
        If KeyCell Is Nothing Then
            Debug.Print "Ключ  """ & RealTrim(CurCell.Value) & """ не найден"
        Else
            i = 2
            Text = "'"
            Do While KeyCell.Cells(1, i).Value <> "#" And i < 15
                Text = Text & Left(KeyCell.Cells(1, i).Value & Space(60), 60)
                i = i + 1
            Loop
            TextsRange.Cells(CurCell.Row - RO, CurCell.Column - CO).Value = Trim(Text)
        End If
   
    Next CurCell
End Sub

Sub SAPBEXonRefresh(queryID As String, resultArea As Range)
End Sub