Михаил, доброе утро! Это если только целые числа, а не 30,5 например. Хотя пример учебный, конечно. P.S. -{999;60;40;30} - красота! 👍 Формулы массива в старых версиях
и т.п. А тема - "Сократить формулу с многократно повторяющейся частью условий" P.S. У меня разделитель целой и дробной части - точка. Обычно в русской локализации используется запятая, тогда замените 0.5 на 0,5 или на 1/2 , а 1.5 на 1,5 или на 3 /2
О! И мне тоже Кристина нравится, хоть я её и не знаю В той теме несложный, но познавательный вопрос. Назвать бы только тему так: "Как сократить формулу с многократно повторяющейся частью условий?"
FearesT написал: ... спасибо большое ... Очень помогло, хотя 100 процентного решения не нашлось...
Добрый день! Приятно, что информация помогла и спасибо, что написали об этом! Тема сама по себе интересная, прорабатывал когда-то и свои варианты. Надстройка Fuzzy Lookup - хороший компромисс между качеством и скоростью обработки. Проверка и корректировка результата в любом случае потребуется. Очень удобно, что эта надстройка может предлагать несколько вариантов на выбор с их точностями. Радует, что и в PQ есть нечеткий поиск. Но только в версиях Excel [2021 и 365[/COLOR] (спасибо за уточнение Алексею Nilske), и тормозит на больших массивах, а также не даёт выбора вариантов совпадения (автовыбор не всегда оптимален). И, кстати, в Plex добавлена возможность вызова GPT для подобных целей, пока это экзотика, медленная, немного платная, но перспективная.
Счастливчик написал: А как поменять? Просто поменять везде XPS на PDF?
В коде в 2х местах вместо Like "*XPS*" нужно записать Like "*PDF*" , получится: Вот измененный фрагмент кода для PDF принтера:
Код
' Temporary set up PDF printer
If Not sPrnName Like "*PDF*" Then
sBuf = String(2 ^ 14, Chr(0))
i = GetProfileString("Devices", vbNullString, vbNullString, sBuf, Len(sBuf))
sBuf = Left(sBuf, i)
For Each vFileName In Split(sBuf, Chr(0))
If vFileName Like "*PDF*" Then
sXpsName = vFileName & " (Ne" & Right("00" & j, 2) & ":)"
Application.ActivePrinter = sXpsName
Exit For
End If
j = j + 1
Next
End If
Цитата
Счастливчик написал: Огромнейшее спасибо за помощь!
Счастливчик написал: А можно как-то сам код оптимизировать кроме того, что уже улучшено, чтобы он быстрее работал?
Проверяйте:
Код
Код
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#Else
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String,ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#End If
Sub ZVI_FastPageSettings()
' ZVI:2024-04-28 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=164667
' Ускорить код, задающий параметры печати
Const ISDEBUG = 0 ' 0/1 for Ready/Debug
Static sFolder As String
Dim sFile As String, sPrnName As String, sXpsName As String, sBuf As String, sDevices() As String
Dim vFileName As Variant, ActSheet As Variant
Dim Ws As Worksheet
Dim colFiles As Collection
Dim i As Long, j As Long, t As Long
' Choose Folder
If sFolder = vbNullString Then sFolder = ThisWorkbook.Path & "\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = sFolder
.Title = "Выберите папку с XLS* для установки парамеров страниц"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Обработка файлов отменена", vbExclamation, "Завершение"
Exit Sub
Else
sFolder = .SelectedItems(1) & "\"
End If
End With
' Collect file names
Set colFiles = New Collection
sFile = Dir(sFolder & "*.XLS*", vbNormal)
While sFile <> vbNullString
colFiles.Add sFolder & sFile
sFile = Dir()
Wend
If colFiles.Count = 0 Then
MsgBox "Нет XLS* файлов в папке:" & vbLf & sFolder, vbExclamation, "Завершение"
Exit Sub
End If
' Save current printer name
sPrnName = Application.ActivePrinter
' Temporary set up XPS printer
If Not sPrnName Like "*XPS*" Then
sBuf = String(2 ^ 14, Chr(0))
i = GetProfileString("Devices", vbNullString, vbNullString, sBuf, Len(sBuf))
sBuf = Left(sBuf, i)
For Each vFileName In Split(sBuf, Chr(0))
If vFileName Like "*XPS*" Then
sXpsName = vFileName & " (Ne" & Right("00" & j, 2) & ":)"
Application.ActivePrinter = sXpsName
Exit For
End If
j = j + 1
Next
End If
' Disable screen blinking & events
If Not ISDEBUG Then
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo exit_
End If
' Disable PrintCommunication
Application.PrintCommunication = False
' Process XLS* files in the choosen folder
j = 0
i = colFiles.Count
t = Timer
For Each vFileName In colFiles
With Workbooks.Open(vFileName, UpdateLinks:=False)
j = j + 1
Set ActSheet = .ActiveSheet
Application.StatusBar = "Файл " & j & " из " & i & " : " & .Name
Application.PrintCommunication = False
For Each Ws In .Worksheets
If Ws.Visible Then
Ws.DisplayPageBreaks = False
Ws.Activate
ActiveWindow.View = xlNormalView
With Ws.PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = False
End With
End If
Next
Application.PrintCommunication = True
ActSheet.Activate
.Close SaveChanges:=True
End With
Next
t = Timer - t
Application.StatusBar = False
' Restore previous active printer
Application.ActivePrinter = sPrnName
exit_:
' Set NormalView in ActiveSheet
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
' Restore disabled settings
Application.PrintCommunication = True
Application.ScreenUpdating = True
Application.EnableEvents = True
' Show statistics/error
If Err Then
MsgBox Err.Description, vbCritical, "Ошибка: " & Err.Number
Else
MsgBox "Успешно обработано файлов: " & colFiles.Count _
& " за " & t & " сек" & vbLf _
& "В папке:" & vbLf & sFolder, vbInformation, "Завершение"
End If
End Sub
Счастливчик написал: Так а как тогда настроить в файлах виртуальный принтер?
Цитата из #19:
Цитата
ZVI написал: Выберите вручную один из этих принтеров до запуска кода. Если эффект будет, то активный принтер устанавливается и программно (это отдельный вопрос)
Вы проверили, есть эффект? Выбранный вручную (или программно) активный принтер устанавливается для всех файлов, открываемых в Excel.
Судя по вопросам и комментариям, в VBA у Вас особого опыта нет. Ничего страшного, но лучше об этом явно написать, чтобы сэкономить всем время А то мы советы даем в расчете на навыки в VBA. Тогда описать проблему можно было бы так: Здравствуйте! У меня есть папка с файлами XLS. Хотелось бы выбрать в диалоге эту папку, а затем поочередно открывать книги в ней, и в параметрах страницы каждого (?) листа устанавливать книжную ориентацию и разместить не более, чем на 1 страницу в ширину (и 1 (?) страницу в высоту). Другие параметры страниц не менять(?). После этого нужно автоматически их сохранить и закрыть. Спрашивать о необходимости сохранения изменений - это лишнее (?). Использую приложенный медленный код. Он написан с использованием макрорекордера (?). Открытие книг и установка параметров страницы тормозит: 23 файла обрабатываются несколько минут. Принтер - сетевой (?). C VBA опыта немного, самостоятельно оптимизировать код не получается. Помогите, пожалуйста, с вариантом кода для ускорения обработки.
Счастливчик написал: Не понял, это вместо моего кода? А открытие файлов это ускорит?...
Вы иронизируете или правда не понимаете код? Это не готовое решение, а чей-то пример использования метода, альтертативного Application.PrintCommunication, который применяли давно до появления PrintCommunication. Ответ по ускорению открытия файлов был в сообщении #7:
Цитата
ZVI написал: ... перед загрузкой выбрать виртуальный принтер
Виртуальный принтер - это чисто программный принтер без физического железа. Обычно используется для записи (распечатки) в файл. Вот 2 виртуальных принтера, которые использует Excel:
Эти картинки можно увидеть из Excel на ленте Файл - Печать, или при нажатии Ctrl-P. Выберите вручную один из этих принтеров до запуска кода. Если эффект будет, то активный принтер устанавливается и программно (это отдельный вопрос).
Это понятно, но интересовал процесс работы менеджеров. Разве не странно, что им присылают пустые ячейки? Разумнее же, чтобы там уже были значения, соответcтвующие прогнозу, приведенному в A:D. Или у них в должностных инструкциях записано требование по навыкам с СУММЕСЛИ?
С моей точки зрения, все столбцы [План продаж] должны приходить к менеджерам заполненными, а в столбце [План1 - План] они должны вписать свои корректировки в новый [План1]. Например, для Таблицы 4:
Ну это никак не может быть связано с тем, что я советовал. Может, что-то не так добавили или зацепили. Чтобы найти проблему нужно закомментировать On Error Resume Next и отладить код, например, построчно, нажимая F8. Глядя на код было впечатление, что о VBA и отладке какое-то представление имеется. Как уточнил Алексей (Jack Famous), рекомендованные строчки правильнее вставлять до и после цикла For-Next, так как ранее есть выходы из кода по Exit Sub, хотя это для данного кода не критично.
Цитата
Подскажите, пожалуйста, как всё это сделать?
"Вид - Обычный, а не Страничный/Разметка" означает вкладку Вид на ленте:
Доброе утро! Интересно, каким инструментом пользуются 3 менеджера для изменения плана с 8-ю разрядами после запятой, чтобы баланс сошелся? Не вручную же )
Нужно, чтобы в VBA разделителем целой и дробной части была точка. Как посмотреть, что там запятая: Debug.Print "=RC[-2]*" & x Замените & x на & Replace(x, ",", ".") или на & Trim(Str(x))
Добрый день, Алексей! Спасибо, да, есть такая проблема. Обычно пустые фигуры - прямоугольники появляются и при копировании-вставке с сайтов. Просто удалять, наверное, некорректно, нужно будет проверять, что они пустые. Давно напрашивается сделать к коду надстройку, подумаю.
irabel написал: Если диаграмма находится правее (ниже) последнего столбца с данными (строки), то макрос удаляет такую диаграмму.Поправил немного код, заменил
Zagadka написал: Мне кажется, я его как раз и использовал...или какой-то более старый вариант
У Вас там была предыдущая версия №3 от 2010-06-16. А здесь использовал версию №4 от 2019-03-08, в которой вместо очистки содержимого ячеек они удаляются вместе с форматами и т.п., подробности есть в теме по ссылке моего предыдущего сообщения.
Zagadka написал: Кто может что подсказать из своего опыта?
Добрый день! Использовал код, который когда-то публиковал, сократило сильно (приложил). На большинстве листах, если нажать Ctrl-End, то попадаем к последний столбец листа. Это означает, что множество столбцов и их ячеек справа от данных избыточно попадают в используемый диапазон (UsedRange) и сохраняются в книге.
Ярослав Малышенко написал: Game over но в это время все могут читать текст.
Собственно, сообщение Game over - лишнее, достаточно очистки листа. А задержать игру в Excel можно разными способами: двойной или правый клик, сочетание клавиш, например Ctrl-F, нажать что-нибудь на ленте с диалогом или сообщением и т.п. Фанаты Dictator application это тоже отключают, но здесь вряд ли имеет смысл. Приложил вариант без сообщений с таймером в формате "hh:mm:ss" и с блокировкой (код в модуле листа2) двойного и правого клика
Изменено: ZVI - 07.04.2024 03:01:34(Исправлены кодовые имена листов на Sh1 и Sh2 - спасибо Владимиру (Sokol92)!)
Andypetr, доброе утро. Да это хороший вариант, только автору темы, возможно, удобнее минуты и секунды отображать. Ещё у автофигур обновление надписи прекращается при редактировании ячейки (по F2), а вот Application.StatusBar обновляется и в этом случае. Прорабатывал вариант и с API-таймером с одной кнопкой Start/Stop без MsgBox-ов. Но интерфейс пусть лучше себе автор темы выбирает.
Добрый день, правильнее тему было бы назвать "Копия диапазона, отсортированного в случайном порядке строк, с таймером" Приложил решение.
Код
Код
Option Explicit
Dim dt As Date
Sub Create_Random()
' ZVI:2024-04-05 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=164251
Const TimeLimit = "00:00:15" ' "hh:mm:ss"
Dim a(), b()
If dt > 0 Then
MsgBox "Game is running, use Stop", vbExclamation, "Restart is blocked"
Exit Sub
End If
' Main
With Лист1.Range("A1:B1").CurrentRegion.Resize(, 3)
a() = .Value
With .Columns(3)
.Formula = "=RAND()"
.Value = .Value
End With
.Sort .Cells(3), xlAscending, Header:=xlYes
b() = .Value
.Value = a()
End With
' Write result
Лист2.UsedRange.Offset(1).ClearContents
Лист2.Range("A1:B1").Resize(UBound(a)).Value = b()
' Reset UsedRange
With Лист1.UsedRange: End With
With Лист2.UsedRange: End With
' Charge stop timer
dt = Now + TimeValue(TimeLimit)
Application.OnTime dt, "StopTheGame"
End Sub
Sub StopTheGame()
If dt > 0 Then
Application.OnTime Now, "Auto_Close"
MsgBox "Game is over!", vbInformation, "Game Timer"
End If
Лист2.UsedRange.Offset(1).ClearContents
End Sub
Private Sub Auto_Close()
On Error Resume Next
If dt > 0 Then Application.OnTime EarliestTime:=dt, Procedure:="StopTheGame", Schedule:=False
dt = 0
End Sub