Автоматический вывод спарклайнов в excel 2010 с помощью vba

Автор bzzzu, 28.10.2011, 17:22

« назад - далее »

bzzzu

Добрый вечер всем!
Появилась необходимость в макросе для автоматического вывода\сдвига спарклайна рядом со сводной таблицей.
Есть сводная таблица количество строк и столбцов в которой меняется в зависимости от того, что выбрали в фильтре сводной таблицы. Необходимо при изменении количества строк и столбцов вывести в последнем столбце спарклайны.
Пример прилагается.
Пока застопорилась на том, что не понимаю как правильно в данном случае указать SourceData для спарклайна.
Буду благодарна за подсказку)

Sub Spark1()

c = WorksheetFunction.CountA([4:4])
r = Range("A" & Rows.Count).End(xlUp).Row

   
    Range(Cells(5, c + 1), Cells(r, c + 1)).Select
    Range(Cells(5, c + 1), Cells(r, c + 1)).SparklineGroups.Add Type:=xlSparkColumn, SourceData:= _
    "Range(Cells(5, 2), Cells(5, c))"
    Range(Cells(5, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Visible = True
    Range(Cells(5, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Color.ThemeColor = 10
   
End Sub

Vladimir Shatk

Добрый день!
Попробуйте вот так:
Sub Spark1()
   c = WorksheetFunction.CountA([4:4])
   r = Range("A" & Rows.count).End(xlUp).row
   Range(Cells(5, c + 1), Cells(r, c + 1)).Select
    Set sg = Range(Cells(2, c + 1), Cells(r, c + 1))
    b = Range(Cells(2, 2), Cells(r, c)).Address
    Set slg = sg.SparklineGroups.Add(XlSparkType.xlSparkLine, b)
    Range(Cells(5, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Visible = True
    Range(Cells(5, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Color.ThemeColor = 10
   End Sub

bzzzu


bzzzu

Продолжу тему.
Макрос который при изменении сводной таблицы выводит новые спарклайны работает отлично.
Возникла проблема с удалением старых спарклайнов, а точнее с нахождением их местоположения.

Файл прилагается, код для удаления рабочий и закомментирован, так как не знаю как найти Sp1.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Application.ScreenUpdating = False

a = 4
c = WorksheetFunction.CountA([4:4])
r = Range("A" & Rows.Count).End(xlUp).Row

    'Sp1 = Range(...).Address

    'With ActiveSheet.PivotTables("СводнаяТаблица3")
    '    If Target.Columns(2).Column = .TableRange2.Columns(2).Column Then
    '    Sp1.Select
    '    Selection.SparklineGroups.ClearGroups
    '    End If
    'End With

c = WorksheetFunction.CountA([4:4])
r = Range("A" & Rows.Count).End(xlUp).Row
   
Set sg = Range(Cells(a + 1, c + 1), Cells(r, c + 1))
b = Range(Cells(a + 1, 2), Cells(r, c)).Address

Set slg = sg.SparklineGroups.Add(XlSparkType.xlSparkColumn, b)
Range(Cells(a + 1, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Visible = True
Range(Cells(a + 1, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Color.ThemeColor = 10

Application.ScreenUpdating = True
End Sub

Vladimir Shatk

Может вот так подойдет?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Dim sp1 As SparklineGroup
    Application.ScreenUpdating = False

a = 4
c = WorksheetFunction.CountA([4:4])
r = Range("A" & Rows.Count).End(xlUp).Row
    For Each sp1 In Range(Cells(a, 1), Cells(r, Columns.Count)).SparklineGroups
        sp1.Delete
    Next
    'sp1= Range(...).Address

    'With ActiveSheet.PivotTables("ÑâîäíàÿÒàáëèöà3")
    '    If Target.Columns(2).Column = .TableRange2.Columns(2).Column Then
    '    Sp1.Select
    '    Selection.SparklineGroups.ClearGroups
    '    End If
    'End With

c = WorksheetFunction.CountA([4:4])
r = Range("A" & Rows.Count).End(xlUp).Row
   
Set sg = Range(Cells(a + 1, c + 1), Cells(r, c + 1))
b = Range(Cells(a + 1, 2), Cells(r, c)).Address

Set slg = sg.SparklineGroups.Add(XlSparkType.xlSparkColumn, b)
Range(Cells(a + 1, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Visible = True
Range(Cells(a + 1, c + 1), Cells(r, c + 1)).SparklineGroups.Item(1).Points.Highpoint.Color.ThemeColor = 10

Application.ScreenUpdating = True
End Sub

bzzzu