Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Раскраска сводной таблицы - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Раскраска сводной таблицы (Макросы Sub)
Раскраска сводной таблицы
RAN Дата: Четверг, 21.11.2013, 14:42 | Сообщение № 1
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Мяу!
Есть макрос для раскраски сводной таблицы.

[vba]
Код
Sub Мяу()
With ActiveSheet
   If .PivotTables.Count <> 1 Then Exit Sub
   With .PivotTables.Item(1)
       .TableRange1.Interior.Color = xlNone
       tbRowStart = .TableRange1.Row
       tbRowEnd = .TableRange1.Rows.Count + tbRowStart - 1
       tbColStart = .TableRange1.Column
       tbColEnd = .TableRange1.Columns.Count + tbColStart - 1
   End With
   For i = tbRowStart To tbRowEnd
       For j = 2 To tbColEnd Step 2
           If IsNumeric(.Cells(i, j)) Then
               If .Cells(i, j + 1) <> .Cells(i, j) Then
               ' хочу разноцветно
                   .Cells(i, 1).Interior.Color = vbRed
               End If
           End If
       Next
   Next
End With
End Sub
[/vba]
Но в большом массиве все сливается, и анализировать не удобно.
Хотелка - изменить цвет раскраски в зависимости принадлежности ячейки к определенному уровню группировки в сводной таблице. Желательно без использования имени поля.
Подскажите, как прописать условие?
К сообщению приложен файл: 4078141.xlsm (22.6 Kb)

Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеМяу!
Есть макрос для раскраски сводной таблицы.

[vba]
Код
Sub Мяу()
With ActiveSheet
   If .PivotTables.Count <> 1 Then Exit Sub
   With .PivotTables.Item(1)
       .TableRange1.Interior.Color = xlNone
       tbRowStart = .TableRange1.Row
       tbRowEnd = .TableRange1.Rows.Count + tbRowStart - 1
       tbColStart = .TableRange1.Column
       tbColEnd = .TableRange1.Columns.Count + tbColStart - 1
   End With
   For i = tbRowStart To tbRowEnd
       For j = 2 To tbColEnd Step 2
           If IsNumeric(.Cells(i, j)) Then
               If .Cells(i, j + 1) <> .Cells(i, j) Then
               ' хочу разноцветно
                   .Cells(i, 1).Interior.Color = vbRed
               End If
           End If
       Next
   Next
End With
End Sub
[/vba]
Но в большом массиве все сливается, и анализировать не удобно.
Хотелка - изменить цвет раскраски в зависимости принадлежности ячейки к определенному уровню группировки в сводной таблице. Желательно без использования имени поля.
Подскажите, как прописать условие?
Автор - RAN
Дата добавления - 21.11.2013 в 14:42
SkyPro Дата: Четверг, 21.11.2013, 15:10 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1206
Репутация: 255 ±
Замечаний: 0% ±

2010
Так?[vba]
Код
Sub paint()
Dim r1$, r2$, r3$
With ActiveSheet.PivotTables("СводнаяТаблица1")
     r1 = .RowFields(1).Name
     r2 = .RowFields(2).Name
     r3 = .RowFields(3).Name
     .PivotSelect r3 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 65535
     .PivotSelect r2 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 15773696
     .PivotSelect r1 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 255
End With
End Sub
[/vba]

skypro1111@gmail.com

Сообщение отредактировал SkyPro - Четверг, 21.11.2013, 15:11
 
Ответить
СообщениеТак?[vba]
Код
Sub paint()
Dim r1$, r2$, r3$
With ActiveSheet.PivotTables("СводнаяТаблица1")
     r1 = .RowFields(1).Name
     r2 = .RowFields(2).Name
     r3 = .RowFields(3).Name
     .PivotSelect r3 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 65535
     .PivotSelect r2 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 15773696
     .PivotSelect r1 & "[All]" _
         , xlLabelOnly + xlFirstRow, True
         Selection.Interior.Color = 255
End With
End Sub
[/vba]
Автор - SkyPro
Дата добавления - 21.11.2013 в 15:10
RAN Дата: Четверг, 21.11.2013, 23:37 | Сообщение № 3
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Спасибо, Сергей, но не то.
Однако, если долго мявучиться, что-нибудь получится. :)
Правда, помог еще и Excel 2010, который куда разговорчивее партизана 2007.

[vba]
Код
Sub qqq()
      With ActiveSheet
          If .PivotTables.Count <> 1 Then Exit Sub
          With .PivotTables.Item(1)

              .TableRange1.Interior.Color = xlNone
              tbRowStart = .TableRange1.Row
              tbRowEnd = .TableRange1.Rows.Count + tbRowStart - 1

              tbColStart = .TableRange1.Column
              tbColEnd = .TableRange1.Columns.Count + tbColStart - 1
          End With
          For i = tbRowStart To tbRowEnd
              For j = 2 To tbColEnd Step 2
                  If IsNumeric(.Cells(i, j)) Then
                      If .Cells(i, j + 1) <> .Cells(i, j) Then

                          If .Cells(i, 1).PivotField.Orientation = 1 Then
                    If .Cells(i, 1).PivotField.Position = 1 Then
                     .Cells(i, 1).Interior.Color = vbRed
                    ElseIf .Cells(i, 1).PivotField.Position = 2 Then
                     .Cells(i, 1).Interior.Color = vbCyan
                    ElseIf .Cells(i, 1).PivotField.Position = 3 Then
                     .Cells(i, 1).Interior.Color = vbYellow
                    End If
                          End If

                      End If
                  End If
              Next
          Next
      End With

End Sub
[/vba]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Четверг, 21.11.2013, 23:37
 
Ответить
СообщениеСпасибо, Сергей, но не то.
Однако, если долго мявучиться, что-нибудь получится. :)
Правда, помог еще и Excel 2010, который куда разговорчивее партизана 2007.

[vba]
Код
Sub qqq()
      With ActiveSheet
          If .PivotTables.Count <> 1 Then Exit Sub
          With .PivotTables.Item(1)

              .TableRange1.Interior.Color = xlNone
              tbRowStart = .TableRange1.Row
              tbRowEnd = .TableRange1.Rows.Count + tbRowStart - 1

              tbColStart = .TableRange1.Column
              tbColEnd = .TableRange1.Columns.Count + tbColStart - 1
          End With
          For i = tbRowStart To tbRowEnd
              For j = 2 To tbColEnd Step 2
                  If IsNumeric(.Cells(i, j)) Then
                      If .Cells(i, j + 1) <> .Cells(i, j) Then

                          If .Cells(i, 1).PivotField.Orientation = 1 Then
                    If .Cells(i, 1).PivotField.Position = 1 Then
                     .Cells(i, 1).Interior.Color = vbRed
                    ElseIf .Cells(i, 1).PivotField.Position = 2 Then
                     .Cells(i, 1).Interior.Color = vbCyan
                    ElseIf .Cells(i, 1).PivotField.Position = 3 Then
                     .Cells(i, 1).Interior.Color = vbYellow
                    End If
                          End If

                      End If
                  End If
              Next
          Next
      End With

End Sub
[/vba]
Автор - RAN
Дата добавления - 21.11.2013 в 23:37
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Раскраска сводной таблицы (Макросы Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!