Всем привет! Написанный макрос выполняет нужные мне действия довольно быстро и это никак не сказывается на моей работе, но есть одно НО.
Из-за того, что я хочу научиться не только писать макросы, но и писать их грамотно и компактно (не могу избавиться от привычки использоваться .select) прошу у вас помощи. Подскажите, пожалуйста, где и как возможно оптимизировать работу макроса из прикрепленного файла.
Прилагаю также файлы, с которыми работает макрос. Файлу Module14.txt надо изменить txt на bas. Загрузить иначе сюда не получилось. Макрос нужно запускать в книге КП_SV22-065368-02, а также в теле самого макроса прописать путь для открытия файла "ЧЕРНОВИК ДЛЯ....КАНАЛКУ.xlsx"
Код
'Открытие документа для переноса информации
Workbooks.Open Filename:="\\zdt.uwg.local\Обменник\ДПО\Верухин С.А\Макросы\ЧЕРНОВИК ДЛЯ ПЕРЕНОСА СВОК НА КАНАЛКУ.xlsx"
Set dantex = ActiveWorkbook
Я не пока только учусь, поэтому мне нужна ваша помощь. Спасибо! Добавить не получилось код для внутреннего макроса "Call SVOK_DANTEX_INDEX1" Т.к. там около 600 строчек кода, где идет замена одного названия на другого.
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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
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 теперь вместо этого
под этот же алгоритм попадают еще: 'Хомут 'Вентилятор канальный 'Вентилятор канальный шумоизолированный 'Кассетный фильтр достаточно в массив ra добавить еще 4 элемента)
в ваших заменах найдутся еще аналогичные блоки удачи!
Jack Famous, Применил все ваши советы, с массивами ни разу не работал, есть теперь почва для изучения и улучшения навыков в этом деле. Спасибо вам, в будущих макросах буду использовать такой вариант массовой замены, потому что удобно. Единственный минус - большое количество позиций для изменения, долго набивал все в Excel :-D
Ігор Гончаренко, попробовал ваш способ, но по какой-то причине он не менял значения как мне нужно. Способ с такой заменой и интересен и сложен, мне нужно немного поизучать массивы, чтобы понять, что именно вы мне предложили (пока чуточку туповат для понимания).
Вопрос не совсем по теме, кроме Слепцовой, кого еще можно почитать, интересует развитие в сторону массивов и сложных функций для вычисления! И еще один, в какую сторону рыть информацию, в случае, когда мне нужно сделать разделение текста по ячейкам.
Пример: А1 - Шумоглушитель SHK 160/6 Мне нужно чтобы в ячейке А1 было - Шумоглушитель, в ячейке А2 - 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
Сергей Верухин: Единственный минус - большое количество позиций для изменения, долго набивал все в Excel
ну а кто будет формировать список замен, если не вы? Можно на листе написать в 2ух столбцах было-стало и сразу в код получить перечень. Но писать-то надо))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Сергей Верухин, учтите ещё разницу подходов у нас с Ігорем Гончаренко: у меня адаптация "в лоб", то есть ровно то, что вы делаете, теми же способами и методами — я показал, как написать короче и/или ускорить работу.
Ігор Гончаренко же вывел закономерность, правило формирования замен и, поэтому, всё, что под правило не попадёт — не будет заменено или будет заменено некорректно. Учтите это и успехов в VBA
P.S.: Парные замены можно написать короче, но, едва ли это будет понятнее
Код
Dim i&
arr = Array("было1", "стало1", "было2", "стало2")
For i = LBound(arr) To UBound(arr) Step 2
Cells.Replace What:=arr(i), Replacement:=arr(i + 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next i
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
в окне 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-и пар ниже?
если работал первоначальный вариант, то точно так же сработает и предложенный мною только вместо 40 строк кода -16 а с учетом предложения еще по 4-м позициям вместо 80 строк кода будет 17, код компактнее в 4 раза! Jack Famous, можно узнать что тут под какое правило не попало
я не тестировал, но, думаю, что ваш вариант вполне корректно отработал по предложенным вариантам. Но только по ним. Если будут другие пары замен, то толку от него не будет, если я правильно понял. Именно это я и сказал учесть. То есть у вас само правило сложнее (у вас даже числовые суффиксы отдельно вынесены) — его также можно дополнять и расширять, но гораздо сложнее чем замена "в лоб". Кода меньше, работает также по скорости, но в понимании и адаптации - сложнее.
Я же показал сам принцип - его можно использовать при любых данных.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Ігор Гончаренко, я лично написал, что для меня Ваш способ не работает, только потому, что "не дорос" еще до такого сложного (на мой взгляд сейчас) описания функций VBA. С точки зрения чего-то нового и что требует внимания и изучения - тут полное попадание. Как время на работе будет, буду изучать и пытаться разобраться в том варианте, который предложили Вы.
[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] - не нужно.
Повторяются в неделимых ячейках обычно слова, написанные выше. (для примера)
Сергей Верухин, вы не мытарства свои описывайте в попытке найти решение, а описывайте задачу написали ОДНУ! фразу: Шумоглушитель SHK 160/6 я написал как разделить ее и ей подобные фразы я не знаю что там у вас еще быввает в данных на сколько частей и как его поделить это-то понимаете? что я не могу угадать с написанием макроса не имея представления, а что там может быть в данных
покажите данные, покажите как они должны быть разделены, может тогда найдется способ как это сделать (для того чтобы понимать очевидные вещи не обязательно что-то понимать в VBA) и... правильно - все это в новой теме)
Сергей Верухин, создайте отдельную тему для разбора разделения строки по ячейкам
Возможно, этого примера хватит
Код
Sub t()
Dim x, aMask()
aMask = Array("*приточная*", "*вытяжная*", "*установка*", "*id*")
For Each x In aMask
Debug.Print LCase$("автоматическая Установка на работе") Like x
Next x
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄