Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.60/5: Рейтинг темы: голосов - 5, средняя оценка - 4.60
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
1

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

07.10.2016, 10:40. Просмотров 923. Ответов 11
Метки нет (Все метки)

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

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
Т.е. макрос ищет в массиве ячейку по переменным и переносит данные и формат.

Помогите доделать это до рабочего состояния.
0
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
07.10.2016, 10:40
Ответы с готовыми решениями:

Редактирование ячейки и перенос значения ячейки через форму
Доброго времени суток люди) Помогите чем сможете, всю голову уже изломали. Сначала хотели кнопку с...

Формула в зависимости от форматирования ячейки
Доброго время суток! Подскажите, пожалуйста, есть задачка. Формула в ячейке должна изменяться в...

Залить фоном ячейки условного форматирования
Здравствуйте, подскажите, пожалуйста макрос, который будет: 1. заливать фоном результаты в...

Отмена авт. форматирования ячейки при вставке
Прошу прощения если повторяюсь (а скорее всего так и есть) просто поиск по сайту в течении пары...

Формулы с ссылками на ячейки
Добрый день форумчане! По работе возникла необходимость написать макрос, что делаю впервые,...

11
KoGG
5303 / 1374 / 325
Регистрация: 23.12.2010
Сообщений: 2,046
Записей в блоге: 1
07.10.2016, 11:38 2
Visual Basic
1
2
3
4
    With Ячейка
        г.Cells(д, в).Copy
        .PasteSpecial Paste:=xlPasteFormats
    End With
Три строки с IF ниже - удалить.
0
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
07.10.2016, 12:07  [ТС] 3
Т.е. так:
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
Переносит в итоге только значение ячейки, без форматов.
0
KoGG
5303 / 1374 / 325
Регистрация: 23.12.2010
Сообщений: 2,046
Записей в блоге: 1
07.10.2016, 13:02 4
Это не UDF, не функция листа.
Функция листа не может переносить цвет.
Только программный вызов функции перенесет цвет.

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

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

Процедуры - это "sub"? Даже не знаю как их прописать тогда, т.к. не знаю как будет выглядеть таблица (точнее сводная таблица постоянно меняется).
0
KoGG
5303 / 1374 / 325
Регистрация: 23.12.2010
Сообщений: 2,046
Записей в блоге: 1
07.10.2016, 13:30 6
Да, процедуры - это "sub", их можно привязать к кнопкам на листе.
0
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
07.10.2016, 15:52  [ТС] 7
Вопрос: как сделать аналог следующего макроса, но через процедуру?

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
Т.е. это формирует первые столбцы с названиями и добавляет группировки строк. Столбцы в первой строке заданы произвольно (названия столбцов которые нужно перенести совпадают с названиями столбцов на других листах, также могут быть не совпадающие наименования или пропуски).
Массив данных (содержание таблицы) хотел заполнить через формулу, которая переносила бы форматы и данные.
Подскажите как это можно сделать?
0
KoGG
5303 / 1374 / 325
Регистрация: 23.12.2010
Сообщений: 2,046
Записей в блоге: 1
07.10.2016, 16:04 8
При всем обилии не нужной информации, нужная информация отсутствует .
Не заданы переменные Массив, ПвСтолбце, ПвСтроке , непонятно откуда брать их значения.
Выложите файл.
0
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
07.10.2016, 17:05  [ТС] 9
Про переменные писал раньше:

Цитата Сообщение от ЛаннКай Посмотреть сообщение
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 'Номер строки конца сводной таблицы
0
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
07.10.2016, 20:33  [ТС] 10
Прикрепил файл с примером.
ячейки выделенные синей заливкой предполагается заполнить макросом переносящим форматы ячеек.
0
Вложения
Тип файла: xlsx Пример Свод.xlsx (17.5 Кб, 2 просмотров)
KoGG
5303 / 1374 / 325
Регистрация: 23.12.2010
Сообщений: 2,046
Записей в блоге: 1
10.10.2016, 13:58 11
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
1
Вложения
Тип файла: rar Пример Свод2.rar (29.9 Кб, 3 просмотров)
ЛаннКай
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 33
11.10.2016, 09:49  [ТС] 12
Спасибо. Буду изучать.
0
11.10.2016, 09:49
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
11.10.2016, 09:49

Ссылка на ячейки, формулы эксель
Доброго времени суток, появился вопрос Код кнопки Private Sub CommandButton8_Click() Dim s As...

Копирование значения ячейки, а не формулы
Проблема в следующем, что надо сделать с ячейкой excel чтоб при копировании копировалось значение а...

Проверка ячейки на наличие в ней формулы
Форумчане, подскажите как собственно осуществить сабж на VBA


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
12
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.