Страницы: 1
RSS
Оптимизация кода макроса
 
Всем привет!
Написанный макрос выполняет нужные мне действия довольно быстро и это никак не сказывается на моей работе, но есть одно НО.

Из-за того, что я хочу научиться не только писать макросы, но и писать их грамотно и компактно (не могу избавиться от привычки использоваться .select) прошу у вас помощи. Подскажите, пожалуйста, где и как возможно оптимизировать работу макроса из прикрепленного файла.

Прилагаю также файлы, с которыми работает макрос. Файлу Module14.txt надо изменить txt на bas. Загрузить иначе сюда не получилось.
Макрос нужно запускать в книге КП_SV22-065368-02, а также в теле самого макроса прописать путь для открытия файла "ЧЕРНОВИК ДЛЯ....КАНАЛКУ.xlsx"

Код
'Открытие документа для переноса информации
Workbooks.Open Filename:="\\zdt.uwg.local\Обменник\ДПО\Верухин С.А\Макросы\ЧЕРНОВИК ДЛЯ ПЕРЕНОСА СВОК НА КАНАЛКУ.xlsx"
    Set dantex = ActiveWorkbook

Я не пока только учусь, поэтому мне нужна ваша помощь. Спасибо!

Добавить не получилось код для внутреннего макроса "Call SVOK_DANTEX_INDEX1"
Т.к. там около 600 строчек кода, где идет замена одного названия на другого.

Вот что там примерно написано:
Код
'Фильтрующая кассета G3 FLFU
Cells.Replace What:="G3 SFPKU 400?200", Replacement:="G3 DV-M01000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 500?250", Replacement:="G3 DV-M02000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 500?300", Replacement:="G3 DV-M02500 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 600?300", Replacement:="G3 DV-M03000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 600?350", Replacement:="G3 DV-M04000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 700?400", Replacement:="G3 DV-M06200 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 800?500", Replacement:="G3 DV-M07000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 900?500", Replacement:="G3 DV-M08500 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="G3 SFPKU 1000?500", Replacement:="G3 DV-M12000 FLFU", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Код
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

Изменено: Сергей Верухин - 10.08.2022 09:45:52
 
Сергей Верухин, здравствуйте
Код нужно вставить в сообщение, как текст, выделить и нажать <…> на панели, чтобы оформить
Изменено: Jack Famous - 10.08.2022 09:31:06
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, добавил код макроса в виде текста
 
Для начала
Изменено: Jack Famous - 10.08.2022 10:07:13
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
добавьте в модуль процедуру
Код
Sub ReplaceGr1()
  Dim i&, j&, ra, rb
  ra = Array(Array("SG 100", "DV-K100 VG"), Array("SKO 100", "DV-K100 OK"), _
  Array("SKD 100", "DV-K100 VK"), Array("SK 100", "DV-K100 KR"), _
  Array("SKH-W 100", "DV-K100 HW"))
  rb = Array("100", "125", "160", "200", "250", "315")
  For i = LBound(rb) To UBound(rb)
    For j = LBound(ra) To UBound(ra)
'      Cells.Replace What:=Replace(ra(j)(0), "100", rb(i)), Replacement:=Replace(ra(j)(1), "100", rb(i)), _
      LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
      Debug.Print Replace(ra(j)(0), "100", rb(i)) & " >>> " & Replace(ra(j)(1), "100", rb(i))
    Next
  Next
End Sub

выполните ее, посмотрите в окне Immediate что на что может заменить эта процедура если раскомментировать закомментированную сейчас строку и можно закомментировать строку с Debug.Print
теперь вместо этого
Код
'Гибкая вставка
Cells.Replace What:="SG 100", Replacement:="DV-K100 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 125", Replacement:="DV-K125 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 160", Replacement:="DV-K160 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 200", Replacement:="DV-K200 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 250", Replacement:="DV-K250 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 315", Replacement:="DV-K315 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

'Обратный клапан
Cells.Replace What:="SKO 100", Replacement:="DV-K100 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKO 125", Replacement:="DV-K125 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKO 160", Replacement:="DV-K160 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKO 200", Replacement:="DV-K200 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKO 250", Replacement:="DV-K250 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKO 315", Replacement:="DV-K315 OK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

'Клапан воздушный
Cells.Replace What:="SKD 100", Replacement:="DV-K100 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKD 125", Replacement:="DV-K125 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKD 160", Replacement:="DV-K160 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKD 200", Replacement:="DV-K200 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKD 250", Replacement:="DV-K250 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKD 315", Replacement:="DV-K315 VK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

'Кронштейн
Cells.Replace What:="SK 100", Replacement:="DV-K100 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SK 125", Replacement:="DV-K125 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SK 160", Replacement:="DV-K160 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SK 200", Replacement:="DV-K200 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SK 250", Replacement:="DV-K250 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SK 315", Replacement:="DV-K315 KR", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

'Воздухонагреватель водяной
Cells.Replace What:="SKH-W 160", Replacement:="DV-K160 HW", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKH-W 200", Replacement:="DV-K200 HW", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKH-W 250", Replacement:="DV-K250 HW", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SKH-W 315", Replacement:="DV-K315 HW", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

достаточно написать
Код
ReplaceGr1
и получите те же замены

под этот же алгоритм попадают еще:
'Хомут
'Вентилятор канальный
'Вентилятор канальный шумоизолированный
'Кассетный фильтр
достаточно в массив ra добавить еще 4 элемента)

в ваших заменах найдутся еще аналогичные блоки
удачи!
Изменено: Ігор Гончаренко - 10.08.2022 10:17:47
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Jack Famous, Применил все ваши советы, с массивами ни разу не работал, есть теперь почва для изучения и улучшения навыков в этом деле. Спасибо вам, в будущих макросах буду использовать такой вариант массовой замены, потому что удобно. Единственный минус - большое количество позиций для изменения, долго набивал все в Excel :-D

Ігор Гончаренко, попробовал ваш способ, но по какой-то причине он не менял значения как мне нужно. Способ с такой заменой и интересен и сложен, мне нужно немного поизучать массивы, чтобы понять, что именно вы мне предложили (пока чуточку туповат для понимания).

Вопрос не совсем по теме, кроме Слепцовой, кого еще можно почитать, интересует развитие в сторону массивов и сложных функций для вычисления!
И еще один, в какую сторону рыть информацию, в случае, когда мне нужно сделать разделение текста по ячейкам.

Пример:
А1 -  Шумоглушитель SHK 160/6
Мне нужно чтобы в ячейке А1 было - Шумоглушитель, в ячейке А2 - SHK 160/6/
После применения макроса, естественно.

В любом случае, всем спасибо огромное!
Изменено: Сергей Верухин - 10.08.2022 16:27:08
 
Цитата
Сергей Верухин написал:
А1 -  Шумоглушитель SHK 160/6
Код
Sub SplitNoLatino()
  Dim r&, re, ms, s$
  Set re = CreateObject("VBScript.RegExp")
  re.Pattern = "[А-Яа-яЁё ]+":  r = 1
  Do While Not IsEmpty(Cells(r, 1))
    s = Cells(r, 1)
    If re.test(s) Then
      Set ms = re.Execute(s)
      Cells(r, 3) = Trim(ms(0))
      Cells(r, 4) = Right(s, Len(s) - Len(ms(0)))
    End If
    r = r + 1
  Loop
End Sub
Изменено: Ігор Гончаренко - 10.08.2022 16:59:37
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Сергей Верухин: Единственный минус - большое количество позиций для изменения, долго набивал все в Excel
ну а кто будет формировать список замен, если не вы?  :)
Можно на листе написать в 2ух столбцах было-стало и сразу в код получить перечень. Но писать-то надо))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, а я и не против потратить рабочее время на написание того, что мне нужно для дальнейшей работы. Так что спасибо вам за помощь!
 
Сергей Верухин, учтите ещё разницу подходов у нас с Ігорем Гончаренко: у меня адаптация "в лоб", то есть ровно то, что вы делаете, теми же способами и методами — я показал, как написать короче и/или ускорить работу.

Ігор Гончаренко же вывел закономерность, правило формирования замен и, поэтому, всё, что под правило не попадёт — не будет заменено или будет заменено некорректно. Учтите это и успехов в VBA  ;)

P.S.: Парные замены можно написать короче, но, едва ли это будет понятнее
Изменено: Jack Famous - 11.08.2022 09:31:53
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
в окне Immediate написаны пары (что на что заменит этот макрос):
SG 100 >>> DV-K100 VG
SG 125 >>> DV-K125 VG
SG 160 >>> DV-K160 VG
SG 200 >>> DV-K200 VG
SG 250 >>> DV-K250 VG
SG 315 >>> DV-K315 VG
....
чем 6 пар выше отличаются от  6-и пар ниже?
Код
'Гибкая вставка
Cells.Replace What:="SG 100", Replacement:="DV-K100 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 125", Replacement:="DV-K125 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 160", Replacement:="DV-K160 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 200", Replacement:="DV-K200 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 250", Replacement:="DV-K250 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="SG 315", Replacement:="DV-K315 VG", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

если работал первоначальный вариант, то точно так же сработает и предложенный мною
только вместо 40 строк кода -16
а с учетом предложения еще по 4-м позициям
вместо 80 строк кода будет 17, код компактнее в 4 раза!
Jack Famous, можно узнать что тут под какое правило не попало
Изменено: Ігор Гончаренко - 11.08.2022 09:48:32
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко: что тут под какое правило не попало
я не тестировал, но, думаю, что ваш вариант вполне корректно отработал по предложенным вариантам. Но только по ним. Если будут другие пары замен, то толку от него не будет, если я правильно понял. Именно это я и сказал учесть.
То есть у вас само правило сложнее (у вас даже числовые суффиксы отдельно вынесены) — его также можно дополнять и расширять, но гораздо сложнее чем замена "в лоб".
Кода меньше, работает также по скорости, но в понимании и адаптации - сложнее.

Я же показал сам принцип - его можно использовать при любых данных.
Изменено: Jack Famous - 11.08.2022 10:26:41
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Ігор Гончаренко, я лично написал, что для меня Ваш способ не работает, только потому, что "не дорос" еще до такого сложного (на мой взгляд сейчас) описания функций VBA. С точки зрения чего-то нового и что требует внимания и изучения - тут полное попадание. Как время на работе будет, буду изучать и пытаться разобраться в том варианте, который предложили Вы.

Хотел еще уточнить по вот этой истории:
Цитата
написал:
Цитата
Сергей Верухин написал:
А1 -  Шумоглушитель SHK 160/6
 
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14      Sub   SplitNoLatino()        Dim   r&, re, ms, s$        Set   re = CreateObject(  "VBScript.RegExp"  )        re.Pattern =   "[А-Яа-яЁё ]+"  :  r = 1        Do   While   Not   IsEmpty(Cells(r, 1))          s = Cells(r, 1)          If   re.test(s)   Then            Set   ms = re.Execute(s)            Cells(r, 3) = Trim(ms(0))            Cells(r, 4) = Right(s, Len(s) - Len(ms(0)))          End   If          r = r + 1        Loop    End   Sub   
 
Этот способ работает отлично, но есть некоторые нюансы, решить которые не могу уже пару часов. Пытался условие дополнительное ввести - не работает. Пытался через переменные, тоже не работает. Мой код ниже.
Пытаюсь сделать исключение, т.к. не все позиции нужно разделять, а если точнее, то вот:
Код
Sub SpliTest()
  Dim r&, re, ms, s$
  Set re = CreateObject("VBScript.RegExp")
  re.Pattern = "[А-Яа-яЁё ]+":  r = 26
  Do While Not IsEmpty(Cells(r, 2))
        If ActiveCell Like "*" & "Установка" & "*" Or ActiveCell Like "*" & "Приточная" & "*" Or ActiveCell Like "*" & "Вытяжная" & "*" _
        Or ActiveCell Like "*" & "id" & "*" Then
            r = r + 1
            GoTo Prodoljit
        End If
    s = Cells(r, 2)
    If re.test(s) Then
      Set ms = re.Execute(s)
      Cells(r, 2) = Trim(ms(0))
      Cells(r, 3) = Right(s, Len(s) - Len(ms(0)))
    End If
Prodoljit:
    r = r + 1
  Loop
End Sub
Собственно, ячейки, в которых есть текст "Установка, Приточная, Вытяжная, id..." разделять не нужно.

Обратный клапан DV-K100 OK нужно делить.
П2 (ОАСС)   id2440491 Приточная установка DV-B05000 R /[P1]-[K1]-[F1]-[SVH-W.3]-[V1.КЦ31С (1.1/3000)]-[H1]-[P1] - не нужно.

Повторяются в неделимых ячейках обычно слова, написанные выше. (для примера)

Изменено: Сергей Верухин - 11.08.2022 10:52:52
 
Сергей Верухин,
вы не мытарства свои описывайте в попытке найти решение, а описывайте задачу
написали ОДНУ! фразу: Шумоглушитель SHK 160/6
я написал как разделить ее и ей подобные фразы
я не знаю что там у вас еще быввает в данных на сколько частей и как его поделить
это-то понимаете? что я не могу угадать с написанием макроса не имея представления, а что там может быть в данных

покажите данные, покажите как они должны быть разделены, может тогда найдется способ как это сделать
(для того чтобы понимать очевидные вещи не обязательно что-то понимать в VBA)
и... правильно - все это в новой теме)
Изменено: Ігор Гончаренко - 11.08.2022 11:16:00
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Сергей Верухин, создайте отдельную тему для разбора разделения строки по ячейкам  ;)
Возможно, этого примера хватит
Изменено: Jack Famous - 11.08.2022 11:16:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх