DAB, в порядке флейма: Предполагаю, что человек в видео коннектится к базе SAP напрямую. Увы, я не знаком с возможностью такого подключения, тут ничего сказать не смогу. Но, как альтернативный вариант, можно использовать в макросах подключение к SAPGUI. Из минусов - для работы макросов нужно будет держать открытым SAP (хотя, наверное, можно автоматизировать и его открытие - сам не реализовывал, точно не скажу). Проще всего записать макрос в SAP'e макро-рекордером, и подправить полученный .vbs скрипт под Ваши нужды. Подразумевается, что Вы знакомы с Visual Basic, и сможете понять что там происходит... Вот вроде бы неплохое видео по похожей теме: SAP GUI Scripting Tricks, Tips and Basics Тут можно взять SAP GUI Scripting API - DEVELOPER GUIDE P.S.: По своему опыту скажу, что создание скриптов Excel-VBA-SAP интересное, но достаточно муторное, и, в общем-то, не слишком надежное. И что самое главное - очень сильно зависит от Вашего контекста - в одной организации у нас все получилось достаточно легко, в другой - даже не смогли начать из-за настроек политики безопасности для SAP'a.
Марина Александрова, возможно у Вас там формула выдает ошибку, а не значение #Н/Д. В теории, можно написать такой макрос:
Код
Dim errRn As Range
' Selection = Текущие выделенные ячейки
For Each ccell In Selection
If IsError(ccell) Then
If errRn Is Nothing Then
Set errRn = ccell
Else
Set errRn = Union(errRn, ccell)
End If
End If
Next ccell
If Not errRn Is Nothing Then
'Значение для замены
errRn.Value = " "
End If
End Sub
Eleonora Lipkina, накидал возможный "Solver", может Вам поможет. Сразу скажу, что пакет подстановки значений не использовал. Общий принцип: расписал прогноз продаж по неделям, ожидаемые стоки после плановых продаж. Далее - смотрим по прогнозу вперед на Х недель (в зависимости от срока доставки конкретного компонента), и если видим, что компонента будет не хватать - делаем заказ. Чтобы избежать циклических ссылок, рассчитанные формулой даты доставки фиксируются в отдельных строках.
ageres1982, кажется, я совсем запутался в своем старом коде, прощу прощения... :-)
Код
Option Explicit
Option Compare Text
Sub XXXX()
...
Dim replaceRn As Range, inputRn As Range, replacementsRn As Range, startingWordsToIgnoreRn As Range, rrow As Range, proceed As String, wordRn As Range, word As String, where_to_replace_cell As Range
' Определяем диапазон со значениями для замен
With ThisWorkbook.Sheets("Замена")
' Фразы для замены
Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
' Если ячейка начинается на эти слова - не делаем замену
Set startingWordsToIgnoreRn = Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
With ThisWorkbook.Sheets("Поиск")
' Устанавливаем стартовый диапазон
Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
' Выделяем стартовый диапазон
replaceRn.Parent.Activate
replaceRn.Select
' Выведем запрос на изменение диапазона
On Error Resume Next
Set inputRn = Application.InputBox( _
Prompt:="Адрес для массовой замены", _
Title:="Замена по списку", _
Default:=replaceRn.Address(True, True, xlA1, True), _
Type:=8)
Err.Clear
On Error GoTo 0
' Если пользователь отменил выделение - выйдем из макроса с предупреждением
If Not inputRn Is Nothing Then
Set replaceRn = inputRn
Else
MsgBox "Диапазон не выбран", vbCritical
Exit Sub
End If
End With
For Each where_to_replace_cell In replaceRn.Cells
' По умолчанию - обрабытываем ячейку
proceed = True
' Проверяем наличие слов из списка
For Each wordRn In startingWordsToIgnoreRn
word = wordRn.Value
If Left(where_to_replace_cell.Cells(1, 1).Value, Len(word)) = word Then
proceed = False
Exit For
End If
Next wordRn
' Если нет слов из списка - начинаем замену.
If proceed Then
' Для каждой пары заменяемых значений сделаем замену
For Each rrow In replacementsRn.Rows
where_to_replace_cell.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
Next rrow
End If
Next where_to_replace_cell
' Выведем сообщение о завершении работы (можно убрать)
MsgBox "Done!", vbInformation
End Sub
Изменено: tolstak - 22.07.2020 13:38:15(В очередной раз поправил формулу :-))
Sub replaceByList()
Dim replaceRn As Range, inputRn As Range, replacementsRn As Range
' Определяем диапазон со значениями для замен
With ThisWorkbook.Sheets("ReplaceList")
' Фразы для замены
Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
' Если ячейка начинается на эти слова - не делаем замену
Set startingWordsToIgnoreRn = Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
With ThisWorkbook.Sheets("Specification")
' Устанавливаем стартовый диапазон
Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
' Выделяем стартовый диапазон
replaceRn.Parent.Activate
replaceRn.Select
' Выведем запрос на изменение диапазона
On Error Resume Next
Set inputRn = Application.InputBox( _
Prompt:="Адрес для массовой замены", _
Title:="Замена по списку", _
Default:=replaceRn.Address(True, True, xlA1, True), _
Type:=8)
Err.Clear
On Error GoTo 0
' Если пользователь отменил выделение - выйдем из макроса с предупреждением
If Not inputRn Is Nothing Then
Set replaceRn = inputRn
Else
MsgBox "Диапазон не выбран", vbCritical
Exit Sub
End If
End With
' Для каждой пары заменяемых значений сделаем замену
For Each rrow In replacementsRn.Rows
' По умолчанию - обрабытываем ячейку
proceed = True
' Проверяем наличие слов из списка
For Each wordRn In startingWordsToIgnoreRn
word = wordRn.Value
If Left(rrow.Cells(1, 1).Value, Len(word)) = word Then
proceed = False
Exit For
End If
Next wordRn
' Если нет слов из списка - начинаем замену.
If proceed Then
replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
End If
Next rrow
' Выведем сообщение о завершении работы (можно убрать)
MsgBox "Done!", vbInformation
End Sub
' Для каждой пары заменяемых значений сделаем замену
For Each rrow In replacementsRn.Rows
replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value, LookAt:=xlWhole
Next rrow
maldini89, что-то вроде такого, наверное Вам подойдет:
Код
Sub iterateMacroOnGivenSheets()
sheetsToProcess = Array("Лист1", "Лист2", "Лист3")
For Each aSheet In sheetsToProcess
ThisWorkbook.Sheets(aSheet).Activate
clean
filter
format
Next aSheet
End Sub
WILD_ICE, решить можно, но ячейки Вы все равно зря объединили - они корень зла В самом простом случае, можно добавить доп. столбцы, и в них соединять ключ вида 101№1,, 101№2, 101№3 и т.д. И по нему ВПРить.
s_v_g, да, верно. Можно было, наверное, использовать Ваши формулы - ничего бы не поменялось. Но пока думал как сделать - навертел аналогичное решение, а переделывать уже не хотелось. :-)
Sub generateShape()
Dim ws As Worksheet, sh As Shape
Set ws = ActiveSheet
With ws
shWidth = .Cells(2, 7).Value
shHeight = .Cells(3, 7).Value
Set sh = .Shapes.AddShape(msoShapeDonut, 150, 150, shWidth, shHeight)
sh.Select
End With
End Sub
Димитрий2, не знаю почему, но когда я меняю вызов evaluateDotMove2 на evaluateDotMove, все работает как надо... Проверил тексты, вроде бы правильно везде добавлены двойки, но почему-то не работает... В целом, идея функций - вынесение одинакового расчета в отдельный блок, и вызов его по необходимости. Т.к evaluateDotMove зависит исключительно от переданных параметров, достаточно вызывать только эту функцию, а evaluateDotMove2 и angleReflect2 не нужны.
' Скорость движения - случайное значение в интервале от 5 до 15
dotsCoordsArr(i, 3) = 2 ' Фиксированная скорость 2 - как пример
'dotsCoordsArr(i, 3) = Application.RandBetween(5, 15)
This will hide the VBE window, but you may still see it flicker. To prevent this, you must use the LockWindowUpdate Windows API function.
Код
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hWndLock As Long) As Long
Sub EliminateScreenFlicker()
Dim VBEHwnd As Long
On Error GoTo ErrH:
Application.VBE.MainWindow.Visible = False
VBEHwnd = FindWindow("wndclass_desked_gsk", _
Application.VBE.MainWindow.Caption)
If VBEHwnd Then
LockWindowUpdate VBEHwnd
End If
'''''''''''''''''''''''''
' your code here
'''''''''''''''''''''''''
Application.VBE.MainWindow.Visible = False
ErrH:
LockWindowUpdate 0&
End Sub
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
With Application.Workbooks("1.xls").Sheets("Лист3")
On Error Resume Next
.[A1] = .[A1] + 1
runDotMovementStep
...
Код
' Массив с данными по точкам (x(range),y(range),угол, скорость движения)
Public dotsCoordsArr()
' Точки считаны
Public dotsValuesAreSetBool As Boolean
' Считываем текущие координаты точек, устанавливаем угол направления и скорость движения
Sub dotsInitialise()
Dim coordsRn As Range
Set coordsRn = ThisWorkbook.Sheets("Лист3").Range("C6:D26")
' dotsCoordsArr(i) = (i_xRn,i_yRn,i_curAngle, i_curSpeed)
If dotsValuesAreSetBool = False Then
' Определяем границы массива
ReDim dotsCoordsArr(0 To coordsRn.Rows.Count - 1, 0 To 3)
' Пробегаемся по всем строкам с данными о точках
For i = 0 To coordsRn.Rows.Count
With coordsRn.Rows(i + 1)
' Записываем данные в массив если значение - не пустое
If Not (IsEmpty(.Cells(1).Value)) And Not (IsEmpty(.Cells(2).Value)) Then
' i_xRn
Set dotsCoordsArr(i, 0) = .Cells(1)
' i_yRn
Set dotsCoordsArr(i, 1) = .Cells(2)
' Угол - случайное значение в интервале от -180 до 180
dotsCoordsArr(i, 2) = Application.RandBetween(-180, 180)
' Скорость движения - случайное значение в интервале от 5 до 15
dotsCoordsArr(i, 3) = Application.RandBetween(5, 15)
End If
End With
Next i
' Значения считанын
dotsValuesAreSetBool = True
End If
End Sub
Sub runDotMovementStep()
' Первый запуск - заносим в массив информацию о точках и присваиваем направление со скоростью
If dotsValuesAreSetBool = False Then dotsInitialise
' Пробегаемся по массиву данных
For i = LBound(dotsCoordsArr, 1) To UBound(dotsCoordsArr, 1)
' Если X и Y - не пустые - расчитываем движение точки
If _
Not IsEmpty(dotsCoordsArr(i, 0)) And _
Not IsEmpty(dotsCoordsArr(i, 1)) _
Then
' Запускаем расчет (x,y,angle, speed)
newCoordsArr = evaluateDotMove( _
CInt(dotsCoordsArr(i, 0).Value), _
CInt(dotsCoordsArr(i, 1).Value), _
CInt(dotsCoordsArr(i, 2)), _
CInt(dotsCoordsArr(i, 3)) _
)
' Записываем координаты, обновляем данные об угле и скорости(не реализовано изменение)
dotsCoordsArr(i, 0).Value = newCoordsArr(0)
dotsCoordsArr(i, 1).Value = newCoordsArr(1)
dotsCoordsArr(i, 2) = newCoordsArr(2)
dotsCoordsArr(i, 3) = newCoordsArr(3)
End If
Next i
End Sub
' Расчет движения точки
Function evaluateDotMove( _
x As Integer, _
y As Integer, _
angle As Integer, _
speed As Integer, _
Optional minX As Integer = 0, _
Optional minY As Integer = 0, _
Optional maxX As Integer = 100, _
Optional maxY As Integer = 100 _
) As Variant
newAngle = angle
' Координаты по X и Y
newX = x + CInt((speed * Cos(angle / (180 / Application.Pi()))))
newY = y + CInt((speed * Sin(angle / (180 / Application.Pi()))))
' Если выходим за допустимые диапазоны - расчитаем положение и угол отражения
If newX > maxX Then
newX = maxX - (newX - maxX)
newAngle = angleReflect(angle, 90)
ElseIf newX < minX Then
newAngle = angleReflect(angle, 270)
newX = newX * -1
End If
If newY > maxY Then
newY = maxY - (newY - maxY)
newAngle = angleReflect(angle, 180)
ElseIf newY < minY Then
newY = newY * -1
newAngle = angleReflect(angle, 0)
End If
' Запишем данные в возвращаемый массив
ReDim dotMoveArr(0 To 3)
dotMoveArr(0) = newX
dotMoveArr(1) = newY
dotMoveArr(2) = newAngle
dotMoveArr(3) = speed
evaluateDotMove = dotMoveArr
End Function
' http://qaru.site/questions/14049611/calculate-angle-change-after-hitting-a-tilted-wall
Function angleReflect(incidenceAngle, surfaceAngle) As Integer
a = surfaceAngle * 2 - incidenceAngle
If a >= 360 Then
angleReflect = a - 360
ElseIf a < 0 Then
angleReflect = a + 360
Else
angleReflect = a
End If
End Function
Создание пустых строк Между заполненными (в таблице), Нужно создать пустые строки между заполненными (в таблице). Количество Необходимых строк - прописано в столбце
Sub createEmptyRows()
' С текущим листом
With ActiveSheet
' Диапазон действия - все строки с ячейки A2 по последнюю заполненную в колонке A
Set actionRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow
' Диапазон с кол-вом строк для вставки
Set rowsToCreateAmountCol = .Range("K:K")
' Для каждой строки после которй нужно вставить пустые строки (с конца к началу)
For i = actionRn.Rows.Count To 1 Step -1
' В диапазон под текущей строкой
' вставить кол-во строк из пересечения текущей строки с колонкой K
actionRn.Rows(i).Offset(1, 0).Resize(RowSize:=Intersect(actionRn.Rows(i), rowsToCreateAmountCol).Cells(1).Value).Insert
Next i
End With
End Sub
Sub cellsColors()
For Each ccell In Selection.Cells
ccell.Value = ccell.Interior.Color
Next ccell
End Sub
Можно использовать предопределенные цвета, вроде VbYellow (как в примере) - список тут. Или скопируйте ячейку, выполните макрос, и подставьте в код вместо VbYellow номер цвета из ячейки.