Sub UpdateEmbeddedChartDataRangeAndRemoveEmptyRows()
    If Not ActiveWindow.Selection.Type = ppSelectionShapes Then
        MsgBox "Пожалуйста, выделите диаграмму на слайде."
        Exit Sub
    End If

    Dim shp As Shape
    Set shp = ActiveWindow.Selection.ShapeRange(1)

    If Not shp.HasChart Then
        MsgBox "Выделенный объект не является диаграммой."
        Exit Sub
    End If

    Dim cht As Chart
    Set cht = shp.Chart

    Dim wb As Object
    Set wb = cht.ChartData.Workbook
    Dim ws As Object
    Set ws = wb.Worksheets(1)

    Dim i As Long, lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 2).End(-4162).Row

    ' Удаляем полностью пустые строки в диапазоне B3:DlastRow (с конца вверх)
    For i = lastRow To 3 Step -1
        If wb.Application.WorksheetFunction.CountA(ws.Range("B" & i & ":D" & i)) = 0 Then
            ws.Rows(i).Delete
        End If
    Next i

    ' Определяем новый lastRow
    lastRow = ws.Cells(ws.Rows.Count, 2).End(-4162).Row

    If lastRow < 3 Then
        MsgBox "Недостаточно данных."
        wb.Close False
        Exit Sub
    End If

    Dim dataRange As String
    dataRange = "B3:D" & lastRow
    Dim fullRangeAddress As String
    fullRangeAddress = "'" & ws.Name & "'!" & ws.Range(dataRange).Address(ReferenceStyle:=1)

    cht.SetSourceData Source:=fullRangeAddress

    wb.Close False

    MsgBox "Диаграмма обновлена: " & fullRangeAddress
End Sub