Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 След.
Макрос выбора файла в каталоге заменить на папку текущего файла
 
MikeVol, спасибо, работает, по коду понял что нужно менять. Но потерялась часть функционала - информация о количестве страниц отображается, как "0", т.е. неверно. Т.е. замена произошла,
Код
xFdItem
которая используется дальше
Код
Open (xFdItem & xFileName) For Binary As #xFileNum
на  
Код
fPath
поэтому надо поправить код в этой части вот так
Код
Open (fPath & xFileName) For Binary As #xFileNum

И тогда будет работать идеально. Еще раз спасибо!
Макрос выбора файла в каталоге заменить на папку текущего файла
 
Добрый день! Подскажите как изменить код (нашел на просторах интернета):
Код
Sub Sbor_imen_failov_i_stranic()
    Dim i As Long
    Dim xRg As Range
    Dim xStr As String
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Dim xFileNum As Long
    Dim RegExp As Object
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
        Worksheets.Add.Name = "Приложения"
        Set xRg = Sheets("Приложения").Range("A1")
        Range("A:B").ClearContents
        Range("A1:B1").Font.Bold = True
        xRg = "Имя файла"
        xRg.Offset(0, 1) = "Кол-во страниц"
        i = 2
        xStr = ""
        Do While xFileName <> ""
            Cells(i, 1) = xFileName
            Set RegExp = CreateObject("VBscript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = "/Type\s*/Page[^s]"
            xFileNum = FreeFile
            Open (xFdItem & xFileName) For Binary As #xFileNum
                xStr = Space(LOF(xFileNum))
                Get #xFileNum, , xStr
            Close #xFileNum
            Cells(i, 2) = RegExp.Execute(xStr).Count
            i = i + 1
            xFileName = Dir
        Loop
        Columns("A:B").AutoFit
    End If
End Sub

Чтобы вместо открытия диалога с выбором файлов, выбирались файлы из папки, в которой находится текущий файл Excel, из которого запускается макрос. Понимаю, что здесь нужно изменить часть кода:
Код
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
но знаний не хватает как скорректировать. Спасибо за помощь!
Изменено: delph3r - 12.08.2025 08:01:44
Переключение между книгами макросом
 
В общем решил сам. В этом варианте работает все как я и хотел. Выкладываю код.
Код
Sub Подготовка_удалить_колонки()
  
'Первая часть макроса: Перемещаем листы в новую книгу
Dim ActiveSht As Worksheet
'Dim NewWb As Workbook
Dim wbOld As Workbook, wbNew As Workbook
For Each wbOld In Workbooks
wbOldname = ActiveWorkbook.name
For Each ActiveSht In ThisWorkbook.Worksheets
ActiveSht.Visible = True ' делаем скрытые листы видимыми в исходной книге.
Next
   
Sheets(Array("Исходные данные", "Сопровод", "ПЗ МЭР", "ПЗ", "КЦ", "Справочник", "СПЕЦОС ОК", "СПЕЦОС ПК")).Move ' Здесь указываете имена нужных листов
Set NewWb = ActiveWorkbook
For Each ActiveSht In NewWb.Worksheets
With ActiveSht.UsedRange
.Value = .Value
End With
Next
'NewWb.SaveAs FileName:="C:\" & "Копия.xls" ' листов стало много - какое имя нужно давать для книги не знаю.
'MsgBox "Формы документов перенесены в новую книгу и сохранены.", vbInformation
'ThisWorkbook.Close SaveChanges:=False
  
  
'Вторая часть макроса: удаление внешних связей
   'Dim wbOld As Workbook, wbNew As Workbook
    'Set wbOld = ActiveWorkbook
     
    'Set wbNew = Workbooks.Add(1)
    Windows(wbOldname).Activate
      
exist_links = ActiveWorkbook.LinkSources(xlExcelLinks)
 
If Not IsEmpty(exist_links) Then
For i = LBound(exist_links) To UBound(exist_links)
' MsgBox exist_links(i)
ActiveWorkbook.BreakLink name:=exist_links(i), Type:=xlLinkTypeExcelLinks
Next
Else
MsgBox "Связей не найдено"
End If
  
'Третья часть макроса: Настройка формата под себя
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    'Sheets("Исходные данные").UsedRange.Value = Sheets("Исходные данные").UsedRange.Value
    'Sheets("ПЗ МЭР").UsedRange.Value = Sheets("ПЗ МЭР").UsedRange.Value
    'Sheets("ПЗ").UsedRange.Value = Sheets("ПЗ").UsedRange.Value
    Application.DisplayAlerts = False
    'Sheets("Справочник").Delete
    Application.DisplayAlerts = True
    'Sheets("КЦ").Visible = xlSheetsHidden
    Sheets("Ф.1(1д)").Visible = xlSheetHidden
Изменено: delph3r - 28.07.2025 09:37:18
Переключение между книгами макросом
 
Цитата
написал:
Вместо wbOld укажите книгу, в которой нужно удалить связи.

Так вот в том и проблема, что имя книги не фиксировано, оно может быть любым. Так-то бы да, я написал "разорви внешние связи с книгой с именем таким-то", но имя книги не известно. Может его можно как-то запомнить изначально. И потом использовать в макросе? Знаний банально не хватает. Я пошерстил форум, но что-то ответ не нашел.
Изменено: delph3r - 28.07.2025 09:05:01
Переключение между книгами макросом
 
Подскажите, может кто-то сможет.
Код
'Первая часть макроса: Перемещаем листы в новую книгу
Dim ActiveSht As Worksheet
Dim NewWb As Workbook
For Each ActiveSht In ThisWorkbook.Worksheets
ActiveSht.Visible = True ' делаем скрытые листы видимыми в исходной книге.
Next
  
Sheets(Array("Исходные данные", "Сопровод", "ПЗ МЭР", "ПЗ", "КЦ", "Справочник")).Move ' Здесь указываете имена нужных листов
Set NewWb = ActiveWorkbook
For Each ActiveSht In NewWb.Worksheets
With ActiveSht.UsedRange
.Value = .Value
End With
Next
'NewWb.SaveAs FileName:="C:\" & "Копия.xls" ' листов стало много - какое имя нужно давать для книги не знаю.
MsgBox "Формы документов перенесены в новую книгу и сохранены.", , ""
'ThisWorkbook.Close SaveChanges:=False
В этой части макроса из книги А переносятся листы в новую книгу - пусть будет Б. Как после переключится снова на книгу А (если имя ее не фиксированное, могут быть открыты другие книги), чтобы продолжилась выполняться следующая часть макроса, которая разорвать внешние связи должна (в т.ч. с перенесенными листами ранее)? Сейчас когда выполняется эта часть макроса, она выполняется на вновь открытую книгу Б, что естественно неверно, макрос должен примениться к книге А.
Код
'Вторая часть макроса: удаление внешних связей
exist_links = ActiveWorkbook.LinkSources(xlExcelLinks)
 
If Not IsEmpty(exist_links) Then
For i = LBound(exist_links) To UBound(exist_links)
' MsgBox exist_links(i)
ActiveWorkbook.BreakLink name:=exist_links(i), Type:=xlLinkTypeExcelLinks
Next
Else
MsgBox "Связей не найдено"
End If

Вариант МатросНаЗебре,  не работает, как раз таки появляется сообщение MsgBox "Связей не найдено", потому что переключение на книгу А (первоначальную) не происходит видимо.

Спасибо заранее.
Переключение между книгами макросом
 
МатросНаЗебре, долго отсутствовал, потому что профиль на другом пк. Макрос, на книге, которая не содержит связи не запускаю. Последовательность просто изначально была заложена, что сначала выносим листы в отдельную книгу, а в старой разрываем связи.
Переключение между книгами макросом
 
МатросНаЗебре,

Цитата
написал:
Присмотритесь к #4. Именно это там и решено.
Я понял. Я сейчас вторую часть свою удалил и заменил вашим блоком полностью, но он создает лишние пустые книги и связи все равно не разрывает.
 
Код
  Dim wbOld As Workbook, wbNew As Workbook    Set wbOld = ActiveWorkbook
     
    Set wbNew = Workbooks.Add(1)
     
    Dim exist_links As Variant
    exist_links = wbOld.LinkSources(xlExcelLinks)
    If Not IsEmpty(exist_links) Then
        Dim i As Long
        For i = LBound(exist_links) To UBound(exist_links)
            ' MsgBox exist_links(i)
            wbOld.BreakLink Name:=exist_links(i), Type:=xlLinkTypeExcelLinks
        Next
    Else
        MsgBox "Связей не найдено", vbExclamation
    End If
     
    'Как активировать?
    'Активировать - бэд практик, ну да ладно.
    wbOld.Activate
    MsgBox ActiveWorkbook.Name, vbInformation
    wbNew.Activate
    MsgBox ActiveWorkbook.Name, vbInformation
Изменено: delph3r - 25.07.2025 14:26:31
Переключение между книгами макросом
 
МатросНаЗебре,

Основная ошибка все еще в том, что после окончания второй части макроса
Код
'Вторая часть макроса: удаление внешних связей
exist_links = ActiveWorkbook.LinkSources(xlExcelLinks)
 
If Not IsEmpty(exist_links) Then
For i = LBound(exist_links) To UBound(exist_links)
' MsgBox exist_links(i)
ActiveWorkbook.BreakLink name:=exist_links(i), Type:=xlLinkTypeExcelLinks
Next
Else
MsgBox "Связей не найдено"
End If
он выводит сообщение "Связей не найдено", т.е. все таки ищет связи в новой книге, которая была создана до этого, в которой как бы и нет связей, а надо вернуться старую и там разорвать связи.
Переключение между книгами макросом
 
Цитата
написал:
Лист "Ф.1(1д)" в исходной книге есть?
Да, есть
Переключение между книгами макросом
 
МатросНаЗебре,

Немного не уловил куда часть кода ставить, которая в #4? Если подставляю код только из #3, то не работает.  
Переключение между книгами макросом
 
Добрый день!
Прошу помочь. Набрал макрос из нескольких других для своих целей, но не хватает знаний, чтобы соединить их воедино и не вылетала ошибка. По отдельности они прекрасно работают.
Код
Sub Подготовка_удалить_колонки()

'Первая часть макроса: Перемещаем листы в новую книгу
Dim ActiveSht As Worksheet
Dim NewWb As Workbook
For Each ActiveSht In ThisWorkbook.Worksheets
ActiveSht.Visible = True ' делаем скрытые листы видимыми в исходной книге.
Next
 
Sheets(Array("Исходные данные", "Сопровод", "ПЗ МЭР", "ПЗ", "КЦ", "Справочник")).Move ' Здесь указываете имена нужных листов
Set NewWb = ActiveWorkbook
For Each ActiveSht In NewWb.Worksheets
With ActiveSht.UsedRange
.Value = .Value
End With
Next
'NewWb.SaveAs FileName:="C:\" & "Копия.xls" ' листов стало много - какое имя нужно давать для книги не знаю.
MsgBox "Формы документов перенесены в новую книгу и сохранены.", , ""
'ThisWorkbook.Close SaveChanges:=False


'Вторая часть макроса: удаление внешних связей
exist_links = ActiveWorkbook.LinkSources(xlExcelLinks)

If Not IsEmpty(exist_links) Then
For i = LBound(exist_links) To UBound(exist_links)
' MsgBox exist_links(i)
ActiveWorkbook.BreakLink name:=exist_links(i), Type:=xlLinkTypeExcelLinks
Next
Else
MsgBox "Связей не найдено"
End If

'Третья часть макроса: Настройка формата под себя
    Set wb = ActiveWorkbook
    'Sheets("Исходные данные").UsedRange.Value = Sheets("Исходные данные").UsedRange.Value
    'Sheets("ПЗ МЭР").UsedRange.Value = Sheets("ПЗ МЭР").UsedRange.Value
    'Sheets("ПЗ").UsedRange.Value = Sheets("ПЗ").UsedRange.Value
    Application.DisplayAlerts = False
    Sheets("Справочник").Delete
    Application.DisplayAlerts = True
    'Sheets("КЦ").Visible = xlSheetsHidden
    Sheets("Ф.1(1д)").Visible = xlSheetsHidden
...

Проблема возникает со второй части, т.к. в первой части переносятся листы в новую книгу и получается, что эта книга становится "активной" и уже вторая часть - удаление внешних связей работает в этой новой книге, но по факту связи должны разрываться в изначальной книге. Вопрос: как сделать первичную книгу активной (*наименование первичной книги может быть любым). И далее как потом опять не нарваться на такую же проблему при переходе в третью часть макроса? Спасибо за ответ!

P.S. Конец макроса выложен не полностью, потому что он огромный и содержит "личную" информацию, прошу не судить строго.
Выделение диапазона ячеек макросом
 
МатросНаЗебре, спасибо за ответ, результат получен.

Зато доходчиво, пример приложен и без суеты)
Возможно лучше подошло бы "определение диапазона макросом".
Выделение диапазона ячеек макросом
 
Добрый день!
Прошу помочь. В данной теме нашел макрос: тема
Использую его чтобы в книге на листах превратить табличную часть в значения.
Код
Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value

После этого идет следующая строчка кода, изменение только в названии листа

Код
Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value

И вот на ней происходит ошибка. Т.е. полностью код выглядит так:
Код
Sub Тест_выделения_диапозона()
Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("A").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value
Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value = Sheets("B").Range("D14", Cells(Rows.Count, "X").End(xlUp).Offset(, 3)).Value
End Sub
Как можно исправить? Пример приложил. Спасибо за ответ!
Форма в Excel сформирована, как объединенные микростолбцы
 
БМВ, спасибо за опыт. Была какая-то надежда на волшебство и на то, что может я чего-то не знаю.
Форма в Excel сформирована, как объединенные микростолбцы
 
nilske, это понятно, но таким образом мы уберем объединение, а колонки останутся. Грубо говоря на текущий момент имеем вот такой вид:

если убираем объединение, то получим такой вид:

а нужен такой вид:

Т.е. на первом скрине ячейка занимает несколько столбцов, а на последнем ячейка занимает один столбец.
Изменено: delph3r - 11.03.2025 06:17:47
Форма в Excel сформирована, как объединенные микростолбцы
 
Добрый день!
Подскажите существует ли способ (не ручной) переделать ЭТО в нормальный вид таблицы, где каждая ячейка = одной ячейке, а не каждая ячейка = много ячеек объеденных в одну?
Пример во вложении.
Спасибо!  
Сохранение пользовательской функции при копировании листа
 
Цитата
написал:
Попробуйте это: Сбивается путь к UDF из надстройки
О, Сам создатель функции здесь! Спасибо за ответ! Это я тоже использую, но я кажется осознал в чем все таки затык при моем способе - это запрос на подтверждение при открытии книги с надстройкой... По сути может она и не открывается макросом вовсе, т.к. не проходит этот запрос...



Разрешите простой вопрос, как отключить все эти предупреждения макросами? Я знаю только:
Код
Application.DisplayAlerts = 0

Прописал сейчас его в модуль книги с надстройкой и не помогло.

Изменено: delph3r - 10.02.2025 10:44:17
Сохранение пользовательской функции при копировании листа
 
Цитата
написал:
delph3r , если эта книга будет использоваться на этом компьютере - то используйте код из надстройки. И не надо усложнять её испоользование - можно просто положить файл надстройки в каталог автозапуска Экселя.
Файл будет распространен людям, которые не понимают как это работает, в том числе "положить файл надстройки в каталог автозапуска Экселя". Еслибы пользовался только я, то я бы запускал ее именно как Вы говорите. Можете ли подсказать решение, чтобы без участия пользователя?
Сохранение пользовательской функции при копировании листа
 
Добрый день!

Подскажите знающие люди..
Условия задачи:
Файл Excel с пользовательской функцией (называется: "СцепитьЕсли2") записана, как модуль VBA при помощи Function, которая используется на листе. При создании копии в новую книгу в ячейке, где была пользовательская функция появляется ошибка "#ИМЯ?".
Вопрос: Как сохранить пользовательскую функцию при создании копии в новую книгу и не было соответствующей ошибки.

Мои попытки:
-Вынести функцию в отдельную книгу путем сохранения в формате "надстройка Excel, формат .xlam". Автоматически открывать эту книгу при открытии основной книги. Для этого использую макрос, который записываю в VBA Эта книга:
Код
Sub Auto_Open()
Workbooks.Open Filename:="...\СцепитьЕсли2.xlam"
End Sub
Эффект - не работает. Получается книга не открывается макросом... поэтому не работает. Когда открываю книгу руками, то работает. Может надо как-то докрутить и я что-то не учел? Или предложите другое решение.
Спасибо!
Вывести диапозон целых чисел между двух чисел с дальнейшими математическими расчетами
 
Цитата
написал:
в моей  формуле ЕСЛИ проверяет года на условие больше начального, меньше равно конечного, при истине возвращается коэффициент этого года, иначе 1, потом все это перемножается ПРОИЗВЕД
Спасибо еще раз!
Вывести диапозон целых чисел между двух чисел с дальнейшими математическими расчетами
 
Цитата
написал:
Код=ПРОИЗВЕД(ИНДЕКС(B2:V2;C5-B1+2):ИНДЕКС(B2:V2;E5-B1+1))
_Boroda_, Хотя Ваше решение выдает значение 1,10317, при установки данных Базовый год - 2020 и Планируемый год - 2020, что является некорректным, т.к. между этими годами нет диапазона.
Изменено: delph3r - 06.02.2025 11:30:56
Вывести диапозон целых чисел между двух чисел с дальнейшими математическими расчетами
 
bigorq, _Boroda_,  спасибо! Не ожидал, что такой молниеносный ответ будет..

Если не затруднит, то немножко суть объяснить, потому что хочется в багаж знаний положить для будущих задач.
Вывести диапозон целых чисел между двух чисел с дальнейшими математическими расчетами
 
Добрый день!
Прошу помощи..

Описание задачи:

Т.е. мы задаем в столбец "Базовый год" строку "Год" и строку "Цена",

потом задаем слобец "Планируемый год" строку год".

Столбец "Индекс" должен "понять", что в диапозон между 2020 и 2016 гг. входят 2017, 2018, 2019, 2020 и взять произведение индексов из таблицы соответствующие годам.

В итоге столбец "Планируемый год" строка "Цена" заполняется автоматически умножением Цены Базового года x Индекс = Цену Планируемого года.

Вопрос: Как можно получить индекс путем ввода только Базового года и Планируемого года?*

*Понятно, что хочется способа более компактного, чем мой, т.к. какая тут таблица (здоровенная) будет, если закончить ее полностью.

Файлик приложил.

Спасибо за помощь!

P.S. В распоряжении только Excel 2016

Изменено: delph3r - 06.02.2025 11:12:28
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
Цитата
написал:
у вас пример рафинированно ограничен
Абсолютно согласен.

Цитата
написал:
т.е. по сути вопрос в следующем - надо ли всегда сравнивать применимость с абсолютно каждым значением кол-ва? и если надо и при этом несколько значений в сумме <= применимости, то какие их них суммировать? - по дате поступления (опять же fifo/lifo) или по иному принципу?
Думаю, что необходимо всегда сравнивать применимость с абсолютно каждым значением количества. По дате поступления - fifo.

Цитата
написал:
upd: прикрепил свой вариант
Большое спасибо!

Цитата
написал:
upd2: существенное упрощение для любого условия - необходимо сразу фильтром убрать все поступления, которые >применяемости. в моем коде это сразу исключит недостаток условия продолжения цикла в List.Generate, про который написал. Изм-й в код не вносил - после join'а необходимо поставить условие сравнения с применяемостью и фильтрануть.
Имеете ввиду добавить Пользовательский столбец с условием [Количество]>[Применяемости]?
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
voler83, прошу прощения, что не отвечал, т.к. не имел доступ к уч. записи до сегодняшнего дня.
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
Цитата
написал:
сущая монстра
Благодарю за уделенное время и помощь! Вернусь, когда протестирую и попытаюсь запустить и разобраться с кодом. Хотя мой уровень конечно не подходит для чтения таких кодов, но все таки.
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
Цитата
написал:
известно ли максимальное предельное кол-во строк в правой таблице (таблица Лист2), которые могут соответствовать значениям левой таблицы (табл Лист1) если делать левый join? - т.е. например "в левую таблицу для каждого значения никогда не подтянется больше 10 значений из правой"
Не знал о такой особенности в PQ при объединении запросов. Что имеется ввиду
Цитата
написал:
в левую таблицу для каждого значения никогда не подтянется больше 10 значений из правой"
? Как это ошибка должна выглядеть?

В исходной таблице при объединении запросов у меня подцепляются более 60 строк по Коду из Таблицы2 к Таблице1. Т.е. создается колонка со значениями Table, при их раскрытии там более 60 строк наименований совпадающих по Коду.
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
Цитата
написал:
p.s. И, кстати, раз уж вы так легко меняете условия использования "поступлений", то условие ограничения по периоду дат ("между") уже выглядит не очень - может быть надо ограничивать поступления сверху, т.е. "не позднее". Но это только вам известно...
Это я просто для примера сделал, чтобы как-то понятнее объяснить. По факту естественно данные являются константой по цене, дате и тд. Просто я не могу их представить здесь в первичном виде, поэтому приходится "выдумывать" пример.
Изменено: delph3r - 22.05.2024 13:51:33
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
AlienSx,

Ну т.е. мысль о том, что можно сначала группировать значения по коду, а потом их уже внутри как-то "фильтровать" кодом (т.е. ограничивать выборку по условию даты) и потом суммировать Количество нарастающим итогом, пока это не превысит Потребность и в итоге вывести среднее значение цены, вывести максимальную дату, вывести суммарное количество, и сцепить в одну строку обоснование.

Т.е. работать вот с этими данными как-то можно? Это же уже отсортированные данные.


Это не правильный ход мыслей?
Изменено: delph3r - 22.05.2024 13:53:03
Power Query. Объединение таблиц с множеством условий, Power Query. Объединение таблиц с множеством условий
 
AlienSx,

Когда-то была задача из группы с одинаковыми кодом, но разными датами найти максимально актуальную дату. Пробовал работать по этой теме. Тут я понял, что идет как раз группировка по условию "№" и потом уже из этой группы выводится максимальная Дата, и в целом получилось отработать по такому примеру. Но как это модифицировать, к моей текущей задаче не знаю. Но это так, уже лирика.
Изменено: delph3r - 22.05.2024 11:28:25
Страницы: 1 2 След.
Наверх