Sub Макрос1()
  With ActiveSheet
    .Unprotect Password:="0000"
    .Cells.Locked = False
    .Columns("A:A").Locked = True
    .Protect Password:="0000", AllowFormattingRows:=True, AllowFormattingColumns:=True
  End With
End Sub

Sub Test_GetPTTooltip()
    Debug.Print GetPTTooltip(ActiveCell)
End Sub
'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
' Purpose: Получение подсказки из ячейки сводной таблицы
'---------------------------------------------------------------------------------------
Function GetPTTooltip(rCell As Range)
    Dim optc As PivotCell
    Dim pf As PivotField
    Dim pi As PivotItem, pc, pp As Object
    Dim s$, spiv$, sOut$
    Dim lp&
    
    On Error Resume Next
    Set optc = rCell.PivotCell
    Err.Clear
    If Not optc Is Nothing Then
        sOut = optc.PivotField.Caption & vbLf
        Select Case optc.PivotCellType
        Case xlPivotCellValue 'любая ячейка в области значений
            If optc.RowItems.Count Then
                sOut = sOut & "Строка: "
                For Each pi In optc.RowItems
                    spiv = pi.LabelRange.Value
                    If Len(spiv) Then
                        sOut = sOut & " - " & spiv
                    End If
                Next
            End If
            If optc.ColumnItems.Count Then
                sOut = sOut & "Столбец: "
                For Each pi In optc.ColumnItems
                    spiv = pi.LabelRange.Value
                    If Len(spiv) Then
                        sOut = sOut & " - " & spiv
                    End If
                Next
            End If
        Case xlPivotCellPivotItem 'любая ячейка в области строк или столбцов
            Set pp = optc.PivotRowLine
            If Not pp Is Nothing Then
                If pp.PivotLineCells.Count Then
                    sOut = sOut & "Строка: "
                    For Each pc In pp.PivotLineCells
                        spiv = pc.PivotItem.LabelRange.Value2
                        If Len(spiv) Then
                            sOut = sOut & " - " & spiv
                        End If
                    Next
                End If
            End If
            Set pp = Nothing
            Set pp = optc.PivotColumnLine
            If Not pp Is Nothing Then
                If pp.PivotLineCells.Count Then
                    sOut = sOut & "Столбец: "
                    For Each pc In pp.PivotLineCells
                        spiv = pc.PivotItem.LabelRange.Value2
                        If Len(spiv) Then
                            sOut = sOut & " - " & spiv
                        End If
                    Next
                End If
            End If
        End Select
    End If
    GetPTTooltip = sOut
End Function

Sub UnexpectedProperty()
    Range("B1:B2").value = "1"
    Range("A1:A2").value = Range("B1:B2").value
    Stop
    Range("B1:B2") = "1"
    Range("A1:A2") = Range("B1:B2")
End Sub

Set dicCopy = dic

Set r1 = Range("A1")
Set r2 = Range("A2")

Set r2 = r1

Set dic = CreateObject("Scripting.Dictionary")          'создали новый объект, ОС выделила под него ссылку на кусочек памяти
Set dicCopy = CreateObject("Scripting.Dictionary")  'создали новый объект, ОС выделила под него ссылку на кусочек памяти

Set dicCopy = dic

Set rr = Range("A1") 

=СУММПРОИЗВ((F3:F18)*{0:0:0:1:0:0:0:0:1:0:0:0:0:0:0:1})/СУММПРОИЗВ(--(((F3:F18)*{0:0:0:1:0:0:0:0:1:0:0:0:0:0:0:1})>0))

=СРЗНАЧЕСЛИМН(F3:F18;Лист2!A3:A18;1;F3:F18;"<>0")

    textPart = "\"" км\/ч\"""
    targetCell.NumberFormat = "0 " & textPart

"?" & """" & textPart & """"

oHttp.setProxy 2, "192.168.1.1:port" 'IP и порт, естественно, свои
oHttp.setProxyCredentials "username", "user_password" 'если надо логиниться

targetCell.NumberFormat = "0 км\/ч"

    Dim textPart$, x
    textPart = "*км/ч"
    'перечисляем все символы, которые должны отображаться как есть
    'и добавляем к ним левый слеш - спец.сивол,
    'который говорит формату использовать следующий за ним символ "как есть"
    For Each x In Array("/", "*")
        textPart = Replace(textPart, x, "\" & x)
    Next
    targetCell.NumberFormat = "0 " & textPart

With TempWB.PublishObjects.Add

TempWB.WebOptions.Encoding = msoEncodingCyrillic