Перенос форматирования ячейки с использованием формулы

@ЛаннКай · Регистрация: 08.01.2016

Студворк — интернет-сервис помощи студентам

Здравствуйте!
Есть макрос который должен копировать формат из переменной "Цвет" в "Ячейка":

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Function ЦветЯчГ(Ячейка, Цвет)
   On Error Resume Next
    
    With Ячейка
        .Interior.Pattern = Цвет.Interior.Pattern
        .Interior.PatternColorIndex = Цвет.Interior.PatternColorIndex
        .Interior.Color = Цвет.Interior.Color
        .Interior.TintAndShade = 0
        .Interior.PatternTintAndShade = 0
        
        .Font.Color = Цвет.Font.Color
        .Font.TintAndShade = 0
        
        .Borders(xlEdgeLeft).LineStyle = Цвет.Borders(xlEdgeLeft).LineStyle
        .Borders(xlEdgeLeft).ColorIndex = Цвет.Borders(xlEdgeLeft).ColorIndex
        .Borders(xlEdgeLeft).TintAndShade = Цвет.TintAndShade
        .Borders(xlEdgeLeft).Weight = Цвет.Borders(xlEdgeLeft).Weight
        
        .Borders(xlEdgeTop).LineStyle = Цвет.Borders(xlEdgeTop).LineStyle
        .Borders(xlEdgeTop).ColorIndex = Цвет.Borders(xlEdgeTop).ColorIndex
        .Borders(xlEdgeTop).TintAndShade = Цвет.TintAndShade
        .Borders(xlEdgeTop).Weight = Цвет.Borders(xlEdgeTop).Weight
        
        .Borders(xlEdgeBottom).LineStyle = Цвет.Borders(xlEdgeBottom).LineStyle
        .Borders(xlEdgeBottom).ColorIndex = Цвет.Borders(xlEdgeBottom).ColorIndex
        .Borders(xlEdgeBottom).TintAndShade = Цвет.TintAndShade
        .Borders(xlEdgeBottom).Weight = Цвет.Borders(xlEdgeBottom).Weight
        
        .Borders(xlEdgeRight).LineStyle = Цвет.Borders(xlEdgeRight).LineStyle
        .Borders(xlEdgeRight).ColorIndex = Цвет.Borders(xlEdgeRight).ColorIndex
        .Borders(xlEdgeRight).TintAndShade = Цвет.TintAndShade
        .Borders(xlEdgeRight).Weight = Цвет.Borders(xlEdgeRight).Weight
        
 
    End With
    
        If Цвет.Font.Bold = True Then Ячейка.Font.Bold = True
        If Цвет.Font.Italic = True Then Ячейка.Font.Italic = True
        If Цвет.Font.Underline = xlUnderlineStyleSingle = True Then Ячейка.Font.Underline = xlUnderlineStyleSingle
        
    ЦветЯчГ = Цвет
 
End Function

Но в нём есть несколько проблем:
1. не переносит толщину и цвет границы ячейки
2. не переносит Ж К Ч
3. заливку переносит только если зайти в ячейку и перезапустить формулу

Для чего нужно: хочу совместить этот макрос со следующим:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Function П2У(Массив, ПвСтолбце, ПвСтроке, Индекс)
On Error Resume Next
Set г = Массив
МассивСтолбец = Массив.Columns(1)
МассивСтрока = Массив.Rows(1)
е = Индекс - Индекс
в = Application.WorksheetFunction.Match(ПвСтроке, МассивСтрока, 0)
д = Application.WorksheetFunction.Match(ПвСтолбце, МассивСтолбец, 0)
б = г.Cells(д, в)
П2У = б
End Function

Где:
Массив - диапазон (таблица) для поиска
ПвСтолбце, ПвСтроке - значения для поиска в первой строке/столбце массива
Индекс - ссылка на ячейку, нужен для перерасчёта макроса (на перерасчёт ячеек не всегда реагирует)

Он переносит значение ячейки из заданного массива.

В итоге получим следующее:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Function ЦветЯчГФ(Ячейка, Массив, ПвСтолбце, ПвСтроке, Индекс)
 
On Error Resume Next
Set г = Массив
МассивСтолбец = Массив.Columns(1)
МассивСтрока = Массив.Rows(1)
е = Индекс - Индекс
в = Application.WorksheetFunction.Match(ПвСтроке, МассивСтрока, 0)
д = Application.WorksheetFunction.Match(ПвСтолбце, МассивСтолбец, 0)
б = г.Cells(д, в)
    
    With Ячейка
        .Interior.Pattern = г.Cells(д, в).Interior.Pattern
        .Interior.PatternColorIndex = г.Cells(д, в).Interior.PatternColorIndex
        .Interior.Color = г.Cells(д, в).Interior.Color
        .Interior.TintAndShade = 0
        .Interior.PatternTintAndShade = 0
        
        .Font.Color = г.Cells(д, в).Font.Color
        .Font.TintAndShade = 0
        
        .Borders(xlEdgeLeft).LineStyle = г.Cells(д, в).Borders(xlEdgeLeft).LineStyle
        .Borders(xlEdgeLeft).ColorIndex = г.Cells(д, в).Borders(xlEdgeLeft).ColorIndex
        .Borders(xlEdgeLeft).TintAndShade = г.Cells(д, в).TintAndShade
        .Borders(xlEdgeLeft).Weight = г.Cells(д, в).Borders(xlEdgeLeft).Weight
        
        .Borders(xlEdgeTop).LineStyle = г.Cells(д, в).Borders(xlEdgeTop).LineStyle
        .Borders(xlEdgeTop).ColorIndex = г.Cells(д, в).Borders(xlEdgeTop).ColorIndex
        .Borders(xlEdgeTop).TintAndShade = г.Cells(д, в).TintAndShade
        .Borders(xlEdgeTop).Weight = г.Cells(д, в).Borders(xlEdgeTop).Weight
        
        .Borders(xlEdgeBottom).LineStyle = г.Cells(д, в).Borders(xlEdgeBottom).LineStyle
        .Borders(xlEdgeBottom).ColorIndex = г.Cells(д, в).Borders(xlEdgeBottom).ColorIndex
        .Borders(xlEdgeBottom).TintAndShade = г.Cells(д, в).TintAndShade
        .Borders(xlEdgeBottom).Weight = г.Cells(д, в).Borders(xlEdgeBottom).Weight
        
        .Borders(xlEdgeRight).LineStyle = г.Cells(д, в).Borders(xlEdgeRight).LineStyle
        .Borders(xlEdgeRight).ColorIndex = г.Cells(д, в).Borders(xlEdgeRight).ColorIndex
        .Borders(xlEdgeRight).TintAndShade = г.Cells(д, в).TintAndShade
        .Borders(xlEdgeRight).Weight = г.Cells(д, в).Borders(xlEdgeRight).Weight
        
 
    End With
    
        If г.Cells(д, в).Font.Bold = True Then Ячейка.Font.Bold = True
        If г.Cells(д, в).Font.Italic = True Then Ячейка.Font.Italic = True
        If г.Cells(д, в).Font.Underline = xlUnderlineStyleSingle = True Then Ячейка.Font.Underline = xlUnderlineStyleSingle
        
    ЦветЯчГФ = б
 
End Function

Т.е. макрос ищет в массиве ячейку по переменным и переносит данные и формат.

Помогите доделать это до рабочего состояния.

@KoGG · 07.10.2016, 11:38

Visual Basic
1
2
3
4
    With Ячейка
        г.Cells(д, в).Copy
        .PasteSpecial Paste:=xlPasteFormats
    End With

Три строки с IF ниже - удалить.

@ЛаннКай · 07.10.2016, 12:07 **[ТС]**

Т.е. так:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Function ЦветЯчГ1(Ячейка, Цвет)
   On Error Resume Next
    
    With Ячейка
        Цвет.Copy
        .PasteSpecial Paste:=xlPasteFormats
    End With
        
    ЦветЯчГ1 = Цвет
 
End Function

Переносит в итоге только значение ячейки, без форматов.

@KoGG · 07.10.2016, 13:02

Это не UDF, не функция листа.
Функция листа не может переносить цвет.
Только программный вызов функции перенесет цвет.

Программный вызов этой функции из другой UDF с листа тоже не принесет эффекта по цвету.

Чтобы не было неопределенности - сделайте все в процедурах.

@ЛаннКай · 07.10.2016, 13:27 **[ТС]**

В моем варианте переносится граница ячеек (без цвета и толщины) и формат данных в ячейке (без Ж К Ч). Думаю возможно доделать.
Что значит "программный вызов функции"? как его сделать? если его можно запихнуть в вызов из ячейки или в кнопку на том же листе, то мне подходит.

Процедуры - это "sub"? Даже не знаю как их прописать тогда, т.к. не знаю как будет выглядеть таблица (точнее сводная таблица постоянно меняется).

@KoGG · 07.10.2016, 13:30

Да, процедуры - это "sub", их можно привязать к кнопкам на листе.

@ЛаннКай · 07.10.2016, 15:52 **[ТС]**

Вопрос: как сделать аналог следующего макроса, но через процедуру?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Function П2У(Массив, ПвСтолбце, ПвСтроке, Индекс)
On Error Resume Next
Set г = Массив
МассивСтолбец = Массив.Columns(1)
МассивСтрока = Массив.Rows(1)
е = Индекс - Индекс
в = Application.WorksheetFunction.Match(ПвСтроке, МассивСтрока, 0)
д = Application.WorksheetFunction.Match(ПвСтолбце, МассивСтолбец, 0)
б = г.Cells(д, в)
П2У = б
End Function

Он должен искать в столбце значение, затем в строке и переносить формат ячейки, причем делать это на разных листах.

Добавлено через 10 минут
В общем дело такое: хотел встроить это в данную последовательность макросов:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub ОчиститьСвод()
Application.Calculation = xlManual
On Error Resume Next
Dim б
г = Sheets("Свод").Range("D2").Value - 1
б = Sheets("Свод").Range("D2").Value - 1
в = Sheets("Свод").Range("D3").Value
For а = 1 To 7000 Step 1
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Sheets("Свод").Rows(г + а).Ungroup
If Sheets("Свод").Cells(б + а, 4) = 1 Then Range(Sheets("Свод").Cells(б + а, 4), Sheets("Свод").Cells(б + а, в)).Clear
Next а
Call СобратьСвод
End Sub

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Sub СобратьСвод()
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
If ws.Name <> "Свод" Then
        Call КопироватьСтроку
End If
Next
Call Переход
Application.Calculation = xlAutomatic
Call ДобавитьПодписи
End Sub

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub КопироватьСтроку()
Dim б
Dim в
б = Sheets("Свод").Range("D1").Value
в = Sheets("Свод").Range("D3").Value
c = в - 3 'в - 4 + 1
r = Worksheets("Свод").Cells(Rows.Count, 4).End(xlUp)(2).Row
For а = 1 To 7000
    If Cells(б + а, 4) = 1 Then
       Worksheets("Свод").Cells(r, 4).Resize(, c) = "=" & Cells(б + а, 4).Address(False, False, , True)
       r = r + 1
End If
If ActiveSheet.Cells(б + а, 4) = 1 Then Range(ActiveSheet.Cells(б + а, 4), ActiveSheet.Cells(б + а, в)).Copy
If ActiveSheet.Cells(б + а, 4) = 1 Then Sheets("Свод").Cells(Rows.Count, 4).End(xlUp).Offset(0).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
If ActiveSheet.Cells(б + а, 4) = 0 Then Exit For
Next а
End Sub

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Переход()
Sheets("Свод").Activate
Sheets("Свод").Cells(1, 1).Activate
Call УдалитьНули
End Sub
Sub УдалитьНули()
Dim б
б = Sheets("Свод").Range("D2").Value - 1
For а = 1 To 7000 Step 1
If Sheets("Свод").Cells(б + а, 5) = 0 Then Sheets("Свод").Range(Sheets("Свод").Cells(б + а, 5), Sheets("Свод").Cells(б + а, 5)).ClearContents
If Sheets("Свод").Cells(б + а, 6) = 0 Then Sheets("Свод").Range(Sheets("Свод").Cells(б + а, 6), Sheets("Свод").Cells(б + а, 6)).ClearContents
If Sheets("Свод").Cells(б + а, 7) = 0 Then Sheets("Свод").Range(Sheets("Свод").Cells(б + а, 7), Sheets("Свод").Cells(б + а, 7)).ClearContents
Next а
Call Группировка
End Sub

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Группировка()
г = Trim(Sheets("Свод").Range("D2").Value)
For а = 1 To 7000 Step 1
If Len(ActiveSheet.Cells(г + а, 6)) = 3 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 4 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 5 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 5 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 6 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 6 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 7 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 7 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 7 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 8 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 8 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 8 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 9 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 9 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 9 Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 0 Then If Len(ActiveSheet.Cells(г + а, 7)) <> 0 Then If Left(ActiveSheet.Cells(г + а, 7), 7) <> "Остаток" Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 0 Then If Len(ActiveSheet.Cells(г + а, 7)) <> 0 Then If Left(ActiveSheet.Cells(г + а, 7), 7) <> "Остаток" Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 0 Then If Len(ActiveSheet.Cells(г + а, 7)) <> 0 Then If Left(ActiveSheet.Cells(г + а, 7), 7) <> "Остаток" Then ActiveSheet.Rows(г + а).Group
If Len(ActiveSheet.Cells(г + а, 6)) = 0 Then If Len(ActiveSheet.Cells(г + а, 7)) <> 0 Then If Left(ActiveSheet.Cells(г + а, 7), 7) <> "Остаток" Then ActiveSheet.Rows(г + а).Group
Next а
End Sub

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub ДобавитьПодписи()
Sheets("Свод").Cells(Rows.Count, 4).End(xlUp).Offset(1).FormulaR1C1 = "1"
Sheets("Свод").Cells(Rows.Count, 4).End(xlUp).Offset(2).FormulaR1C1 = "1"
Sheets("Свод").Cells(Rows.Count, 5).End(xlUp).Offset(3).FormulaR1C1 = "Имя1"
Sheets("Свод").Cells(Rows.Count, 5).End(xlUp).Offset(0).Font.Bold = True
Sheets("Свод").Cells(Rows.Count, 4).End(xlUp).Offset(1).FormulaR1C1 = "1"
Sheets("Свод").Cells(Rows.Count, 4).End(xlUp).Offset(2).FormulaR1C1 = "1"
Sheets("Свод").Cells(Rows.Count, 5).End(xlUp).Offset(3).FormulaR1C1 = "Имя2"
Sheets("Свод").Cells(Rows.Count, 5).End(xlUp).Offset(0).Font.Bold = True
Dim д
Dim е
д = Sheets("Свод").Range("C1").Value
е = Sheets("Свод").Range("C2").Value
Sheets("Свод").Cells(Rows.Count, 93).End(xlUp).Offset(3).FormulaR1C1 = д
Sheets("Свод").Cells(Rows.Count, 93).End(xlUp).Offset(0).Font.Bold = True
Sheets("Свод").Cells(Rows.Count, 93).End(xlUp).Offset(3).FormulaR1C1 = е
Sheets("Свод").Cells(Rows.Count, 93).End(xlUp).Offset(0).Font.Bold = True
End Sub

Т.е. это формирует первые столбцы с названиями и добавляет группировки строк. Столбцы в первой строке заданы произвольно (названия столбцов которые нужно перенести совпадают с названиями столбцов на других листах, также могут быть не совпадающие наименования или пропуски).
Массив данных (содержание таблицы) хотел заполнить через формулу, которая переносила бы форматы и данные.
Подскажите как это можно сделать?

@KoGG · 07.10.2016, 16:04

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

@ЛаннКай · 07.10.2016, 17:05 **[ТС]**

Про переменные писал раньше:

Сообщение от ЛаннКай

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Function П2У(Массив, ПвСтолбце, ПвСтроке, Индекс)
On Error Resume Next
Set г = Массив
МассивСтолбец = Массив.Columns(1)
МассивСтрока = Массив.Rows(1)
е = Индекс - Индекс
в = Application.WorksheetFunction.Match(ПвСтроке, МассивСтрока, 0)
д = Application.WorksheetFunction.Match(ПвСтолбце, МассивСтолбец, 0)
б = г.Cells(д, в)
П2У = б
End Function

Где:
Массив - диапазон (таблица) для поиска
ПвСтолбце, ПвСтроке - значения для поиска в первой строке/столбце массива
Индекс - ссылка на ячейку, нужен для перерасчёта макроса (на перерасчёт ячеек не всегда реагирует)
Он переносит значение ячейки из заданного массива.

Применительно к предыдущему сообщению:
ПвСтолбце - данные из столбца с данными (наименованиями) созданного макросом.
ПвСтроке - данные в строке (заданны произвольно, введены с клавиатуры).
Массив - диапазон данных на всех листах, кроме листа "Свод" (на каждом листе свой).

Добавлено через 42 минуты
А также на листе "Свод" есть расчётная таблица, значения ссылок на лист:

Visual Basic
1
2
3
Sheets("Свод").Range("D1").Value 'Номер строки конца наименований
Sheets("Свод").Range("D3").Value 'Номер последнего столбца таблицы
Sheets("Свод").Range("D2").Value 'Номер строки конца сводной таблицы

@ЛаннКай · 07.10.2016, 20:33 **[ТС]**

Прикрепил файл с примером.
ячейки выделенные синей заливкой предполагается заполнить макросом переносящим форматы ячеек.

@KoGG · 10.10.2016, 13:58

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
Option Explicit
 
Sub ОчиститьСвод()
    Application.Calculation = xlManual
    Dim а&, ПерваяСтрока&, ПоследняяСтрока&, ПоследняяСтрокаИтогов&, ПоследнийСтолбец&
    With Sheets("Свод")
        ПоследняяСтрока = .Cells(.Rows.Count, 4).End(xlUp).Row
        ПоследняяСтрокаИтогов = .Range("D1").Value
        ПоследнийСтолбец = .UsedRange.Columns.Count + .UsedRange.Column - 1
        ПерваяСтрока = .Range("D2").Value - 1
        On Error Resume Next
        For а = ПерваяСтрока To ПоследняяСтрока
            If .Cells(а, 4) = 1 Then
                Sheets("Свод").Rows(а).Ungroup
                If а > ПоследняяСтрокаИтогов Then Range(.Cells(а, 4), .Cells(а, ПоследнийСтолбец)).Clear
            End If
        Next а
    End With
    Call СобратьСвод
End Sub
 
Sub СобратьСвод()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Activate
        If ws.Name <> "Свод" Then
            Call КопироватьСтроку
            Sheets("Свод").Activate
        End If
    Next
    Call Переход
    Application.Calculation = xlAutomatic
    Call ДобавитьПодписи
End Sub
 
Sub Переход()
    Sheets("Свод").Activate
    Sheets("Свод").Cells(1, 1).Activate
    Call УдалитьНули
End Sub
 
Sub КопироватьСтроку()
    Dim а&, j%, k%, r&, СтрокаШапкиСвод&, СтрокаШапкиАктивногоЛиста&, ПоследнийСтолбец&, ПоследняяСтрокаАктивногоЛиста&
    Dim Шсвод, Шакт ' Массивы для значений шапок
    With Sheets("Свод")
        СтрокаШапкиСвод = .Range("D2").Value
        ПоследнийСтолбец = .Range("D3").Value
        r = .Cells(Rows.Count, 4).End(xlUp)(2).Row
        Шсвод = Range(.Cells(СтрокаШапкиСвод, 1), .Cells(СтрокаШапкиСвод, ПоследнийСтолбец)).Value
    End With
    With ActiveSheet
        СтрокаШапкиАктивногоЛиста = .UsedRange.Row ' Сейчас 7
        ПоследняяСтрокаАктивногоЛиста = .Cells(.Rows.Count, 4).End(xlUp).Row
        Шакт = Range(.Cells(СтрокаШапкиАктивногоЛиста, 1), .Cells(СтрокаШапкиАктивногоЛиста, ПоследнийСтолбец)).Value
        For а = СтрокаШапкиАктивногоЛиста + 1 To ПоследняяСтрокаАктивногоЛиста
            If .Cells(а, 4) = 1 Then
                Range(.Cells(а, 4), .Cells(а, 5)).Copy
                With Worksheets("Свод").Cells(r, 4).Resize(, 2)
                    .PasteSpecial Paste:=xlPasteFormats
                    .Formula = "=" & ActiveSheet.Cells(а, 4).Address(False, False, , True)
                End With
                For j = 6 To ПоследнийСтолбец
                    For k = 6 To ПоследнийСтолбец
                        With Worksheets("Свод")
                            If Шсвод(1, j) = Шакт(1, k) Then
                                ActiveSheet.Cells(а, k).Copy
                                .Cells(r, j).PasteSpecial Paste:=xlPasteFormats
                                .Cells(r, j).Formula = "=" & ActiveSheet.Cells(а, k).Address(False, False, , True)
                           End If
                        End With
                    Next k
                Next j
                r = r + 1
            ElseIf .Cells(а, 4) = 0 Then
                Exit For
            End If
        Next а
   End With
End Sub
 
Sub УдалитьНули()
    Dim а&, ПерваяСтрока&, ПоследняяСтрока&
    With Sheets("Свод")
        ПоследняяСтрока = .Cells(.Rows.Count, 4).End(xlUp).Row
        ПерваяСтрока = .Range("D2").Value - 1
        For а = ПерваяСтрока To ПоследняяСтрока
            If .Cells(а, 5) = 0 Then .Range(.Cells(а, 5), .Cells(а, 5)).ClearContents
            If .Cells(а, 6) = 0 Then .Range(.Cells(а, 6), .Cells(а, 6)).ClearContents
            If .Cells(а, 7) = 0 Then .Range(.Cells(а, 7), .Cells(а, 7)).ClearContents
        Next а
    End With
    Call Группировка
End Sub
 
Sub Группировка()
    Dim а&, ПерваяСтрока&, ПоследняяСтрока&
    ПерваяСтрока = Val(Sheets("Свод").Range("D2").Value)
    With ActiveSheet
        ПоследняяСтрока = .Cells(.Rows.Count, 6).End(xlUp).Row
        For а = ПерваяСтрока To ПоследняяСтрока
            Select Case .Cells(а, 6)
                Case 3
                    .Rows(а).Group
                Case 4
                    .Rows(а).Group
                Case 5
                    .Rows(а).Group
                    .Rows(а).Group
                Case 6
                    .Rows(а).Group
                    .Rows(а).Group
                Case 7
                    .Rows(а).Group
                    .Rows(а).Group
                    .Rows(а).Group
                Case 8
                    .Rows(а).Group
                    .Rows(а).Group
                    .Rows(а).Group
                Case 9
                    .Rows(а).Group
                    .Rows(а).Group
                    .Rows(а).Group
                Case 0
                    If Left(.Cells(а, 7), 7) <> "Остаток" Then
                        .Rows(а).Group
                        .Rows(а).Group
                        .Rows(а).Group
                        .Rows(а).Group
                    End If
            End Select
        Next а
    End With
End Sub
 
Sub ДобавитьПодписи()
    Dim д, е
    With Sheets("Свод")
        .Cells(Rows.Count, 4).End(xlUp).Offset(1).FormulaR1C1 = "1"
        .Cells(Rows.Count, 4).End(xlUp).Offset(2).FormulaR1C1 = "1"
        .Cells(Rows.Count, 5).End(xlUp).Offset(3).FormulaR1C1 = "Имя1"
        .Cells(Rows.Count, 5).End(xlUp).Offset(0).Font.Bold = True
        .Cells(Rows.Count, 4).End(xlUp).Offset(1).FormulaR1C1 = "1"
        .Cells(Rows.Count, 4).End(xlUp).Offset(2).FormulaR1C1 = "1"
        .Cells(Rows.Count, 5).End(xlUp).Offset(3).FormulaR1C1 = "Имя2"
        .Cells(Rows.Count, 5).End(xlUp).Offset(0).Font.Bold = True
        д = .Range("C1").Value
        е = .Range("C2").Value
        .Cells(Rows.Count, 93).End(xlUp).Offset(3).FormulaR1C1 = д
        .Cells(Rows.Count, 93).End(xlUp).Offset(0).Font.Bold = True
        .Cells(Rows.Count, 93).End(xlUp).Offset(3).FormulaR1C1 = е
        .Cells(Rows.Count, 93).End(xlUp).Offset(0).Font.Bold = True
    End With
End Sub

@ЛаннКай · 11.10.2016, 09:49 **[ТС]**

Спасибо. Буду изучать.

Новые блоги и статьи Все статьи Все блоги /
Почему дизайн решает? Neotwalker 09.01.2026 В современном мире, где конкуренция за внимание потребителя достигла пика, дизайн становится мощным инструментом для успеха бренда. Это не просто красивый внешний вид продукта или сайта — это. . .	Модель микоризы: классовый агентный подход 3 anaschu 06.01.2026 aa0a7f55b50dd51c5ec569d2d10c54f6/ O1rJuneU_ls https:/ / vkvideo. ru/ video-115721503_456239114	Owen Logic: О недопустимости использования связки «аналоговый ПИД» + RegKZR ФедосеевПавел 06.01.2026 Owen Logic: О недопустимости использования связки «аналоговый ПИД» + RegKZR ВВЕДЕНИЕ Введу сокращения: аналоговый ПИД — ПИД регулятор с управляющим выходом в виде числа в диапазоне от 0% до. . .	Модель микоризы: классовый агентный подход 2 anaschu 06.01.2026 репозиторий https:/ / github. com/ shumilovas/ fungi ветка по-частям. коммит Create переделка под биомассу. txt вход sc, но sm считается внутри мицелия. кстати, обьем тоже должен там считаться. . . .
Расчёт токов в цепи постоянного тока igorrr37 05.01.2026 / * Дана цепь постоянного тока с сопротивлениями и напряжениями. Надо найти токи в ветвях. Программа составляет систему уравнений по 1 и 2 законам Кирхгофа и решает её. Последовательность действий:. . .	Новый CodeBlocs. Версия 25.03 palva 04.01.2026 Оказывается, недавно вышла новая версия CodeBlocks за номером 25. 03. Когда-то давно я возился с только что вышедшей тогда версией 20. 03. С тех пор я давно снёс всё с компьютера и забыл. Теперь. . .	Модель микоризы: классовый агентный подход anaschu 02.01.2026 Раньше это было два гриба и бактерия. Теперь три гриба, растение. И на уровне агентов добавится между грибами или бактериями взаимодействий. До того я пробовал подход через многомерные массивы,. . .	Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Programma_Boinc 28.12.2025 Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Налог на собак: https:/ / ********/ gallery/ V06K53e Финансовый отчет в Excel: https:/ / ********/ gallery/ bKBkQFf Пост отсюда. . .

@KoGG 5637 / 1619 / 418 Регистрация: 23.12.2010 Сообщений: 2,428 Записей в блоге: 1
	07.10.2016, 13:02
	Это не UDF, не функция листа. Функция листа не может переносить цвет. Только программный вызов функции перенесет цвет. Программный вызов этой функции из другой UDF с листа тоже не принесет эффекта по цвету. Чтобы не было неопределенности - сделайте все в процедурах. 0

@ЛаннКай 0 / 0 / 0 Регистрация: 08.01.2016 Сообщений: 39
	07.10.2016, 13:27 [ТС]
	В моем варианте переносится граница ячеек (без цвета и толщины) и формат данных в ячейке (без Ж К Ч). Думаю возможно доделать. Что значит "программный вызов функции"? как его сделать? если его можно запихнуть в вызов из ячейки или в кнопку на том же листе, то мне подходит. Процедуры - это "sub"? Даже не знаю как их прописать тогда, т.к. не знаю как будет выглядеть таблица (точнее сводная таблица постоянно меняется). 0

@KoGG 5637 / 1619 / 418 Регистрация: 23.12.2010 Сообщений: 2,428 Записей в блоге: 1
	07.10.2016, 13:30
	Да, процедуры - это "sub", их можно привязать к кнопкам на листе. 0

@KoGG 5637 / 1619 / 418 Регистрация: 23.12.2010 Сообщений: 2,428 Записей в блоге: 1
	07.10.2016, 16:04
	При всем обилии не нужной информации, нужная информация отсутствует . Не заданы переменные Массив, ПвСтолбце, ПвСтроке , непонятно откуда брать их значения. Выложите файл. 0

@ЛаннКай 0 / 0 / 0 Регистрация: 08.01.2016 Сообщений: 39
	11.10.2016, 09:49 [ТС]
	Спасибо. Буду изучать. 0