Sub MacrosForSVOK_Excel()
Application.ScreenUpdating = False
Application.EnableEvents = False
Call SVOK_DANTEX_INDEX1
'Удаление строк с фразами
Set MR = Range("A1:H4000")
For Each cell In MR
If cell.Value = "Итого (оборудование)" Then cell.EntireRow.Delete
Next
For Each cell In MR
If cell.Value = "Итого (КИПиА)" Then cell.EntireRow.Delete
Next
For Each cell In MR
If cell.Value = "Итого" Then cell.EntireRow.Delete
Next
For Each cell In MR
If cell.Value = "КИПиА" Then cell.EntireRow.Delete
Next
'Удаление ненужных слов в КП
Cells.Replace What:="SVOK", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="RUB", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="шт", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'Удаление картинок
ActiveSheet.Pictures.Delete
'Удаление строк с текстом сверху
Do Until Range("A1") = "№"
Rows("1:1").Delete Shift:=xlUp
Loop
'Удаление неактивных листов и переименовывание активного в "КП ДР"
ActiveSheet.Name = "КП ДР"
Dim NoKPDR As Worksheet
Application.DisplayAlerts = False
For Each NoKPDR In Application.ActiveWorkbook.Worksheets
If NoKPDR.Name <> "КП ДР" Then
NoKPDR.Delete
End If
Next
Application.DisplayAlerts = True
'Наценка / Скидка / Перевод в EUR
'Наценка и скидка
Dim Nacenka, Skidka As Integer
Nacenka = Application.InputBox("Укажите наценку на оборудование SVOK")
Range("I1") = Nacenka / 100 + 1
Skidka = Application.InputBox("Введите нашу скидку, которую дает SVOK:")
Range("I2") = 1 - Skidka / 100
'Выбор валюты / Eur или Rub + курс на сегодня
Dim eur As Integer
Dim Msg, Style, Title
Msg = "Если EUR - нажми ДА! ///// Если RUB - нажми НЕТ!"
Style = vbYesNo + vbInformation + vbDefaultButton2
Response = MsgBox(Msg, Style)
If Response = vbYes Then
Dim Euro1 As Double
Euro1 = Application.InputBox("Укажите курс ЕВРО, по которому мы работаем сегодня!")
Range("I3") = Euro1 - 2
eur = 1
Cells.Find(What:="Итого по предложению с учётом НДС", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Else
Cells.Find(What:="Итого по предложению с учётом НДС", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
eur = 0
End If
'Выполнение перевода по формуле для значения цены
ActiveCell.Offset(rowoffset:=-6, columnOffset:=5).Activate
Do
If ActiveCell.Offset(rowoffset:=0, columnOffset:=-3) = "Цена" Then
ActiveCell.Offset(rowoffset:=-5, columnOffset:=0).Activate
End If
If eur = 1 Then
ActiveCell.Value = ActiveCell.Offset(rowoffset:=0, columnOffset:=-3).Value * Cells(1, 9).Value * Cells(2, 9).Value / Cells(3, 9).Value
Else
ActiveCell.Value = ActiveCell.Offset(rowoffset:=0, columnOffset:=-3).Value * Cells(1, 9).Value * Cells(2, 9).Value
End If
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Activate
Loop While ActiveCell.Row <> 1
'Добавление названия документа для КП от СВОКа
'Нужно для понимания программой в какое окно ей переключаться
Dim svok, dantex As Excel.Workbook
Set svok = ActiveWorkbook
'Открытие документа для переноса информации
Workbooks.Open Filename:="\\zdt.uwg.local\Обменник\ДПО\Верухин С.А\Макросы\ЧЕРНОВИК ДЛЯ ПЕРЕНОСА СВОК НА КАНАЛКУ.xlsx"
Set dantex = ActiveWorkbook
svok.Activate
ActiveWorkbook.Sheets.Add.Name = "КП"
dantex.Activate
Range("J39:A1").Select
Selection.Copy
svok.Activate
ActiveSheet.Cells(1, "A").PasteSpecial Paste:=xlPasteColumnWidths
ActiveSheet.Paste
Range("A1").RowHeight = 45
Range("A2").RowHeight = 31.5
'Удаление из буфера скопированного массива и закрытие черновика, откуда была взята форма КП
Application.CutCopyMode = False
On Error Resume Next
dantex.Close False
'С этого момента у нас находится 2 листа в активной книге, которые называются КП ДР и КП
'КП - это страница, куда переносится вся информация
'КП ДР - это страница, откуда переносится информация
'Перенос данных из КП ДР в КП
ActiveWorkbook.Worksheets("КП ДР").Activate
Cells.Find(What:="Итого по предложению с учётом НДС", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Dim LastRowVKP As Integer
LastRowVKP = ActiveCell.Row
ActiveWorkbook.Worksheets("КП").Activate
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Select
Do While ActiveCell.Offset(rowoffset:=-1, columnOffset:=0) = ""
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Select
Selection.EntireRow.Delete Shift:=xlUp
Loop
ActiveCell.Offset(rowoffset:=1, columnOffset:=0).Select
Do While LastRowVKP <> 0
Selection.EntireRow.Insert Shift:=xlShiftDown
LastRowVKP = LastRowVKP - 1
Loop
'Приведение таблицы в божеский вид + добавление форматирования ко всей таблице
Dim LastFirstRow, LastRow As Range
Set LastFirstRow = ActiveCell
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Set LastRow = ActiveCell
Range(LastRow.Offset(rowoffset:=-1, columnOffset:=2), LastFirstRow.Offset(rowoffset:=0, columnOffset:=-6)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).Weight = xlThin
LastFirstRow.Offset(rowoffset:=0, columnOffset:=-6).Activate
Range(ActiveCell, ActiveCell.Offset(rowoffset:=0, columnOffset:=8)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 14277081
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range(ActiveCell, ActiveCell.Offset(rowoffset:=0, columnOffset:=8)).Font.Color = 0
Range(LastFirstRow, LastFirstRow).Offset(rowoffset:=0, columnOffset:=-6).Activate
Set LastFirstRow = ActiveCell
'Начало переноса SVOK на нашу форму DANTEX
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Range(LastFirstRow, LastFirstRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(rowoffset:=1, columnOffset:=0).Select
Set LastFirstRow = ActiveCell
Cells(29, 1).EntireRow.Delete
Dim kolichestvo As Integer
kolichestvo = 0
Do While ActiveWorkbook.Worksheets("КП ДР").Range("B1") = "Наименование"
kolichestvo = kolichestvo + 1
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Range(LastFirstRow, LastFirstRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(rowoffset:=1, columnOffset:=0).Select
Set LastFirstRow = ActiveCell
LastFirstRow.Offset(rowoffset:=-1, columnOffset:=0).Activate
Range(ActiveCell, ActiveCell.Offset(rowoffset:=0, columnOffset:=8)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 14277081
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range(ActiveCell, ActiveCell.Offset(rowoffset:=0, columnOffset:=8)).Font.Color = 0
ActiveCell.Value = "Установка "
LastFirstRow.Select
'Действия в КПДР (СВОК)
ActiveWorkbook.Worksheets("КП ДР").Activate
Range("B1").Offset(rowoffset:=1, columnOffset:=0).Select
Dim FirstRowSV, LastRowSV As Range
Set FirstRowSV = ActiveCell
If ActiveCell.Offset(rowoffset:=1, columnOffset:=0) = "" Then
Set LastRowSV = ActiveCell
Range(ActiveCell, "B2").Select
Selection.Copy
GoTo NextStep2
End If
ActiveCell.End(xlDown).Select
Set LastRowSV = ActiveCell
Range(FirstRowSV, LastRowSV).Select
Selection.Copy
NextStep2:
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells(LastFirstRow.Row, "G").Select
'Действия в КПДР (СВОК)
ActiveWorkbook.Worksheets("КП ДР").Activate
Cells(FirstRowSV.Row, "C").Select
Set FirstRowSV = ActiveCell
Cells(LastRowSV.Row, "C").Select
Set LastRowSV = ActiveCell
Range(FirstRowSV, LastRowSV).Select
Selection.Copy
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells(LastFirstRow.Row, "I").Select
'Действия в КПДР (СВОК)
ActiveWorkbook.Worksheets("КП ДР").Activate
Cells(FirstRowSV.Row, "G").Select
Set FirstRowSV = ActiveCell
Cells(LastRowSV.Row, "G").Select
Set LastRowSV = ActiveCell
Range(FirstRowSV, LastRowSV).Select
Selection.Copy
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
LastFirstRow.Offset(rowoffset:=-1, columnOffset:=6).Select
Selection.ClearContents
LastFirstRow.Offset(rowoffset:=-1, columnOffset:=8).Select
Selection.ClearContents
Cells(LastFirstRow.Row, "G").Select
If ActiveCell.Offset(rowoffset:=1, columnOffset:=0) = "" Then
ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Select
Else
ActiveCell.End(xlDown).Select
ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Select
End If
Set LastFirstRow = ActiveCell
'Действия в КПДР (СВОК)
ActiveWorkbook.Worksheets("КП ДР").Activate
'Удаление установки, которая уже перенесена
Cells(LastRowSV.Row, "H").Select
Range(ActiveCell, "A1").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Selection.EntireRow.Delete Shift:=xlShiftDown
Selection.EntireRow.Delete Shift:=xlShiftDown
Selection.EntireRow.Delete Shift:=xlShiftDown
Selection.EntireRow.Delete Shift:=xlShiftDown
Loop
'Перемножение ячеек I и G, для получения суммы количества установок и цены
ActiveWorkbook.Worksheets("КП").Activate
Cells(LastFirstRow.Row - 1, "J").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-3]"
Do While ActiveCell.Row > 29
If ActiveCell.Offset(rowoffset:=0, columnOffset:=-3) = "" Then
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Activate
Else
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-3]"
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Activate
End If
Loop
'Получения розничных цен за счет умножения стоимости 1 штуки на 2 (розница = цена со скидкой + 76%)
Cells(LastFirstRow.Row, "H").Select
ActiveCell.FormulaR1C1 = "=RC[1]*1,6"
Do While ActiveCell.Row > 29
If ActiveCell.Offset(rowoffset:=0, columnOffset:=-1) = "" Then
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Activate
Else
ActiveCell.FormulaR1C1 = "=RC[1]*2"
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Activate
End If
Loop
'Удаление ненужных строк в КП
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(rowoffset:=-1, columnOffset:=0).Select
Set LastRow = ActiveCell
Range(LastRow, LastFirstRow).Select
Selection.EntireRow.Delete Shift:=xlUp
'Действия в КП (КАНАЛКА)
ActiveWorkbook.Worksheets("КП").Activate
Dim FP, SP, IT As Range
Cells.Find(What:="Розница, EUR. С НДС", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=1, columnOffset:=0).Select
Set FP = ActiveCell
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=0).Select
Set SP = ActiveCell
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=0, columnOffset:=1).Select
Set IT = ActiveCell
Range(FP, SP).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range(IT, IT).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-1]C[1]:R26C[1])"
Range("A1").Activate
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=3).Select
If eur = 0 Then
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=2).Select
Range(ActiveCell, "H27").Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Replace What:="Розница, EUR. С НДС", Replacement:="Розница, RUB. С НДС", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="Цена со скидкой, EUR", Replacement:="Цена со скидкой, RUB", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="Сумма со скидкой, EUR", Replacement:="Сумма со скидкой, RUB", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="ВНИМАНИЕ! Цены указаны в Евро с НДС", Replacement:="ВНИМАНИЕ! Цены указаны в Рублях с НДС", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=1, columnOffset:=-5).Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=0, columnOffset:=1).Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=10, columnOffset:=3).Select
Range(ActiveCell, "T1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=-1).Select
Range(ActiveCell, "J27").VerticalAlignment = xlCenter
End If
If eur = 1 Then
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=2).Select
Range(ActiveCell, "H27").Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=1, columnOffset:=-5).Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=0, columnOffset:=1).Select
'Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "0.00"
Selection.NumberFormat = "#,##0.00"
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=10, columnOffset:=3).Select
Range(ActiveCell, "T1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=-1).Select
Range(ActiveCell, "J27").VerticalAlignment = xlCenter
End If
Cells(28, 1).EntireRow.Delete
Cells(27, 1).EntireRow.Delete
Cells(26, 1).EntireRow.Delete
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("КП ДР").Delete
Application.DisplayAlerts = True
ActiveWorkbook.Worksheets("КП").Activate
'Добавление правила условного форматирования. Заливает шапку белым цветом, даже если вставить текст с другим фоном
Range("A1", "T23").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=СУММ($A$1:$T$23)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A1").Select
'Подсчет количества перенесенных установок
MsgBox "Количество перенесенных установок" & " " & "=" & " " & kolichestvo
'Проверка ячеек в КП с нулевой ценой
Dim Nol As Range
Set Nol = Range("I27:I4000")
For Each cell In Nol
If cell.Value = 0 And cell.Value <> "" Then
cell.Interior.Color = 255
End If
Next
Dim Msg4, Style2, Title2
Msg4 = "Вы будете добавлять нашу автоматику в КП?"
Style2 = vbYesNo + vbInformation + vbDefaultButton2
Response = MsgBox(Msg4, Style2)
If Response = vbYes Then
Call AvtomatikaDobavit
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub AvtomatikaDobavit()
Dim i As Long
For i = 1000 To 28 Step -1
If Cells(i, "B") Like "*" & "Установка" & "*" Then
For s = 1 To 12
Rows(i).Insert
Next s
End If
Next
ActiveSheet.Buttons.Add(968.25, 393, 144, 53.25).Select
Selection.OnAction = "PERSONAL.XLSB!УдалениеСтрокВКПканалка2"
Selection.Characters.Text = "Удалить пустые строки в КП после добавления автоматики и эту кнопку!"
With Selection.Characters(Start:=1, Length:=47).Font
.Name = "Calibri"
.FontStyle = "обычный"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
End Sub
Sub УдалениеСтрокВКПканалка2()
Application.ScreenUpdating = False
Cells.Find(What:="Итого:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Offset(rowoffset:=-1, columnOffset:=-6).Activate
'Set PustieStroki = Range(ActiveCell, "B28")
'For Each Cell In PustieStroki
'If Cell.Value = "" Then Cell.EntireRow.Delete
'Next
Dim i As Long
For i = ActiveCell.Row To 28 Step -1
If Cells(i, "B") = "" Then
Rows(i).Delete
End If
Next
ActiveSheet.Shapes.Range(Array("Button 1")).Delete
Application.ScreenUpdating = True
End Sub
|
