Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » An_2020
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 След.
Защита ячеек паролем с условием
 
#
27.06.2023 10:27:38
Добрый день!
Есть файл, в котором при условии, что сегодня от 15 до 31 число месяца должны блокировать столбцы с месяцами.
Например 16 июля откроется файл и в нём должны заблокироваться столбцы с начала года по текущий месяц +3 месяца (т.е. по октябрь)
Конец августа - по ноябрь
Помогите, пожалуйста
 
Перейти    
Сравнение двух таблиц
 
#
26.05.2023 15:27:00
Добрый день! Такой вопрос:
Есть Таблица1: Яблоки, груши
Таблица2: Яблоки, груши, бананы
Как сделать чтобы код нашел все значения из Таб1 в Таб2?
Написала код, понимаю в чём ошибка, но не понимаю как исправить..
Помогите, пожалуйста

LRK думала писать как LRK =WS.Range("A" & WS.Rows.Count).End(xlUp).Row, но тоже не работает

Вот основная часть кода:
Код
Set WS = ThisWorkbook.Sheets("Отчёт")
Set WSK = WBK.Worksheets("Овощи")
LK = WSK.Range("C" & WSK.Rows.Count).End(xlUp).Row

For RK = 5 To LK
   
    If WS.Cells(LRK, "D") = WSK.Cells(RK, "C") Then
        WS.Cells(LRK, "Q") = WSK.Cells(RK, "BC")
        LRK=LRK+1
    End If
Next RK
Изменено: An_2020 - 26.05.2023 15:30:48
 
Перейти    
Отмечать даты в календаре с указанием информации в примечании
 
#
19.04.2023 15:27:18
Цитата
написал:
An_2020, добавил код, который закрашивает ваш календарь
Спасибо!
Только в одном примечании дублируются фамилии
Мне уже помогли с этим вопросом
еще раз спасибо)
 
Перейти    
Отмечать даты в календаре с указанием информации в примечании
 
#
18.04.2023 07:50:42

Лист забыла переименовать, прикреплю новый файл
Реализовать можно любым способом
Всплывающая подсказка- достаточно просто фамилии. Если два человека взяли выходные, то указать их фамилии в одном комментарии
Изменено: An_2020 - 18.04.2023 07:52:28
 
Перейти    
Отмечать даты в календаре с указанием информации в примечании
 
#
17.04.2023 16:48:01
Добрый день!
Задача состоит в следующем: Сотрудники на листе "Нерабочие дни" указывают свою фамилию и даты нерабочих дней.
А на листе "Календарь",  в ячейках, соответствующих дате закрашивались те самые нерабочие дни и при наведении на этот день была написана фамилия сотрудника
Возможно ли это реализовать?
Помогите, пожалуйста)
Изменено: An_2020 - 18.04.2023 07:51:12
 
Перейти    
Посчитать сумму по условию
 
#
14.04.2023 10:58:05
Добрый день! Вот пример файлов. Получается, что из файла "пример" по значению "товар" должна добавляться сумма с бонусом и общая сумма. Возможно, в будущем критериев отбора (бонусов тп.) будет больше
 
Перейти    
Посчитать сумму по условию
 
#
11.04.2023 09:00:11
Доброго времени суток! Помогите, пожалуйста
Формула СУММЕСЛИМН не подходит, тк каждую неделю файл по мере добавления нового будет меняться (данные берутся из последнего сохранённого в папке. А в формуле придётся каждый раз менять название файла). Как найти последний файл и открыть его уже нашла. Поиск нужного критерия  в столбце "D", а брать значения нужно из "BI". в идеале, чтобы макрос сам распознавал все уникальные значения в столбце "D".
Нужен макрос, который считает сумму по значению. В моём случае по стране. Моих знаний хватило лишь на это:
Код
PZ = ThisWorkbook.Sheets("Справка о динамике")
Arh = S.Open(p)
LR = PZ.Range("A" & PZ.Rows.Count).End(xlUp).Row
LRA = Arh.Range("A" & Arh.Rows.Count).End(xlUp).Row
For RZ = 5 To LRA
    S = Arh.Cells(RZ, "D")
If S = "Азербайджан" Then
Изменено: An_2020 - 11.04.2023 10:15:19
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
04.04.2023 11:15:50
Цитата
написал:
Application.EnableEvents = True
Вот это да, Вы просто Бог Эксель))
Спасибо вам огромное :*  
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
04.04.2023 11:02:40
Цитата
Дмитрий(The_Prist) Щербаков - написал:
Уберите строку On Error Resume Next и идите пошагово, наблюдая на каком шаге ошибка. Это вообще первое, что надо делать в таких случаях
Я даже и не додумалась это убрать....
Временный файл создавался, нужный нет.

Появилась ошибка 424 на строке Set wb = Workbook.Open(sTmpF)

Заменила на Set wb = Workbooks.Open(sTmpF). Всё работает, но проблема в том, что запускаются все макросы в новом файле. Понимаю, что это логично, но можно ли этого избежать?
Спасибо вам большое за  терпение)
Изменено: An_2020 - 04.04.2023 11:03:12
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
04.04.2023 09:45:11

Поменяла Environ("temp") на  strPath и файл после 11 строки появляется, но после завершения End If пропадает

Так же заметила когда прохожу код через F8 и останавливаю его на строке 15, то на строке 13 wb=Nothing при наведении курсора

Изменено: An_2020 - 04.04.2023 09:50:50
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
04.04.2023 09:37:03
Цитата
написал:
файл из 11 строки удаляется - это видно по строке 17. Я же комментарии написал к коду, Вы не читаете их?
Я по строкам проверяла через F8. на 13 строке открываю папку и она пустая.
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
04.04.2023 08:36:53
Цитата
написал:
Попробуйте так
Добрый день! Принцип работы поняла, но ничего не сохраняет.
на 11 строке идёт небольшая загрузка (как будто сохраняет файл), проверила папку на данном шаге, она пустая
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
03.04.2023 15:49:31
Обнаружилась неприятная ситуация, открывается при сохранении копия, а основной файл закрывается...
Как сделать, чтобы копия не открывалась, а основной файл не закрывался?))))
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
03.04.2023 15:43:47
Получилось сохранять без макросов, но появляются уведомления, которые осталось убрать) Всем спасибо
Код
Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "C:\Desktop\Архив" 
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
        strDate = Format(Now, "dd-mm-yy")
        FileNameXls = strPath & "\" & "Отчёт " & " " & strDate & ".xlsx"
        ActiveWorkbook.SaveAs Filename:=FileNameXls, FileFormat:=51
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
03.04.2023 15:28:45
Цитата
сохраните в xlsx
Ошибку выдаёт, что формат не поддерживается файлом
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
03.04.2023 15:27:30
Дмитрий(The_Prist) Щербаков (planetaexcel.ru)
Возможно, я что-то не понимаю, но по ссылке информация как убрать макрос из ЭТОЙ книги, а не сохранить копию без макросов
Изменено: An_2020 - 03.04.2023 15:28:00
 
Перейти    
Сохранение копии файла, но без поддержки макросов
 
#
03.04.2023 11:16:29
Добрый день! Нашла код, который сохраняет копию файла. Но как сделать, чтобы он копировался без поддержки макрсов? А как обычный Эксель файл

Код
Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "C:\Desktop\Архив"     'папка для сохранения резервной копии
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату
        strDate = Format(Now, "dd-mm-yy")
        FileNameXls = strPath & "\" & "Отчёт " & " " & strDate & ".xls"   'или xlsm
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub
 
Перейти    
Сократить код
 
#
30.03.2023 13:24:02
Добрый день! Пыталась написать код, но он у меня в итоге получится МЕГА длинным...
Суть в том, чтобы из выбранного файла методом копипаста вставлялись значения в книгу, в которой и содержится код. У меня это получилось, но очень топорно. Как видите, большинство информации не меняется.

Помогите, пожалуйста

ЗЫ: сейчас прикреплю пример
Код
Dim OD As Workbook
Dim ODS As Worksheet
Dim TDS As Worksheet
Dim LR, RZ As String
Dim PT As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set TDS = ThisWorkbook.Sheets("Свод)
LR = TDS.Range("A" & TDS.Rows.Count).End(xlUp).Row + 1

PT = Application.GetOpenFilename("Excel files(*.xls*),*.xls*, 2,", , True)
Set OD = Workbooks.Open(PT)
Set ODS = OD.Worksheets("Отчет")
'ODS.Unprotect "1234"

'-------------------------------------------
TDS.Cells(LR, "A") = ODS.Cells(6, "C")
TDS.Cells(LR, "B") = ODS.Cells(7, "C")
TDS.Cells(LR, "C") = ODS.Cells(15, "B")
TDS.Cells(LR, "D") = ODS.Cells(15, "E") 
TDS.Cells(LR, "E") = ODS.Cells(15, "C")
TDS.Cells(LR, "G") = ODS.Cells(9, "C")
TDS.Cells(LR, "H") = ODS.Cells(10, "C")
LR = LR + 1
TDS.Cells(LR, "A") = ODS.Cells(6, "C")
TDS.Cells(LR, "B") = ODS.Cells(7, "C")
TDS.Cells(LR, "C") = ODS.Cells(15, "B")
TDS.Cells(LR, "D") = ODS.Cells(15, "F") 
TDS.Cells(LR, "E") = ODS.Cells(15, "C")
TDS.Cells(LR, "G") = ODS.Cells(9, "C")
TDS.Cells(LR, "H") = ODS.Cells(10, "C")
Изменено: An_2020 - 30.03.2023 13:37:29
 
Перейти    
Макрос завершается, но ничего не происходит
 
#
28.03.2023 11:03:29
Цитата
воспользуйтесь макросом другого замечательного человека
Всё работает, спасибо большое))))
 
Перейти    
Макрос завершается, но ничего не происходит
 
#
28.03.2023 10:55:15
Цитата
Это как д'Артаньян? Моя д'Элита?
Первое, что в голову пришло написала и не слово, и мне понятно)
 
Перейти    
Макрос завершается, но ничего не происходит
 
#
28.03.2023 10:53:51
Так скрывает, но только часть строк.
Забыла добавить на другие столбы. Можно вообще так написать?
Код
Sub mydelite()

Dim WS As Worksheet
Dim RZ As Long
Dim LR As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set WS = Workbooks("Справка по автомобилям копия").Sheets("Отчёт")
LR = WS.Range("B" & WS.Rows.Count).End(xlUp).Row

For RZ = 3 To LR
    If WS.Cells(RZ, "E") = WS.Cells(RZ, "F") = WS.Cells(RZ, "G") = "" Then
        Rows(RZ).EntireRow.Hidden = True
    RZ = RZ + 1
    End If
Next RZ

Application.Calculation = xlCalculationAutomatic
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True

End Sub
 
Перейти    
Макрос завершается, но ничего не происходит
 
#
28.03.2023 10:38:38
Добрый день!
На основе кода одного замечательного человека)) пыталась написать код, в котором скрываются строки при условии, что в столбцах E, F и G нет никах значений. Но когда я его запускаю ничего не происходит..
Помогите, пожалуйста
Код
Sub mydelite()

Dim WS As Worksheet
Dim RZ As Long
Dim LR As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set WS = Workbooks("Справка").Sheets("Отчёт")
LR = WS.Range("B" & WS.Rows.Count).End(xlUp).Row

For RZ = 3 To LR
    If WS.Cells(RZ, "E") = " " Then
        Rows(RZ).EntireRow.Hidden = True
    RZ = RZ + 1
    End If
Next RZ

Application.Calculation = xlCalculationAutomatic
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True

End Sub
 
Перейти    
Ошибка 91
 
#
23.03.2023 13:51:04
Как я понимаю, я неверно переменные определила, но исправить не получается
 
Перейти    
Ошибка 91
 
#
23.03.2023 13:48:09
Добрый день!
Изначально планируется чтобы код открывал окно для выбора файла, после чего копипастом значения ячеек переносились в первый файл (WD)
Пыталась написать код, но выдаёт ошибку на строке WBO = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 2, "Выбрать Excel файлы", , True)
Файл я выбрать могу, но после попытки открыть его появляется такая ошибка и WBO=Nothing при наведении на соответствующую переменную, получается он его не видит... И WD тоже самое
Помогите, пожалуйста
Код
Sub serbius()

Dim WBO As Range
Dim WO As Workbook
Dim iLastRow As Long
Dim A As Range
Dim WD As Workbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set WD = ThisWorkbook.Sheets("Ком. деятельность")

WBO = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 2, "Выбрать Excel файлы", , True)

Workbooks(WBO).Sheets("Отчёт").Activate
Range("C7").Copy

WD.Sheets("Ком. деятельность").Activate
iLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row

Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Application.ScreenUpdating = False

WO.Close True

End Sub
 
Перейти    
Ускорить и упростить код, Есть код, который долго работает, как его облегчить?
 
#
16.03.2023 15:13:33
Юрий М, Теперь поняла как нужно отвечать. По моей логике цитирование как бы ответ на сообщение.
Буду знать)
 
Перейти    
Ускорить и упростить код, Есть код, который долго работает, как его облегчить?
 
#
16.03.2023 15:11:47
Цитата
написал:
ActiveWorkbook.Sheets("Расчёт").Range("CO5:CO" & ActiveWorkbook.Sheets("Расчёт").Cells(Rows.Count, "A").End(xlUp)).Copy
Ругается на эту строку, ошибка 1004
 
Перейти    
Ускорить и упростить код, Есть код, который долго работает, как его облегчить?
 
#
16.03.2023 14:26:11
Цитата
написал:
An_2020,
эх...Вы бы лучше показали полностью Ваш код. Думаю, что так будет лучше.
Там тоже самое, только название файлов меняется. Москва, Казань, Омск и тд
Код
Sub Workbook_Open()
Dim arFiles, x, c As Range
Dim iLastRow As Long
Dim A As Range
 
Application.AskToUpdateLinks = False
Workbooks("Основной").Sheets("Расчёт").Range("A5:CO500").Clear
 
Workbooks.Open Filename:="тут указан путь"
Workbooks("Москва").Sheets("Расчёт").Range("CO5", Cells(Rows.Count, "A").End(xlUp)).Copy
 
Workbooks("Основной").Sheets("Расчёт").Activate
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 
Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("Москва").Close True

Application.AskToUpdateLinks = False
Workbooks("Основной").Sheets("Расчёт").Range("A5:CO500").Clear
 
Workbooks.Open Filename:="тут указан путь"
Workbooks("Казань").Sheets("Расчёт").Range("CO5", Cells(Rows.Count, "A").End(xlUp)).Copy
 
Workbooks("Основной").Sheets("Расчёт").Activate
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 
Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("Казань").Close True

Application.AskToUpdateLinks = False
Workbooks("Основной").Sheets("Расчёт").Range("A5:CO500").Clear
 
Workbooks.Open Filename:="тут указан путь"
Workbooks("Омск").Sheets("Расчёт").Range("CO5", Cells(Rows.Count, "A").End(xlUp)).Copy
 
Workbooks("Основной").Sheets("Расчёт").Activate
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 
Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("Омск").Close True

End Sub
 
Перейти    
Ускорить и упростить код, Есть код, который долго работает, как его облегчить?
 
#
16.03.2023 14:08:44
Цитата
написал:
Sub обновить_запросы()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False

'ваш код

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Остальные мои строки с Application оставить? Удалить только 20 строку?
Сейчас загружается так же долго, просто окно эксель зеленое висит вместо открытого файла. Получается я просто не вижу момент загрузки из других файлов
Изменено: An_2020 - 16.03.2023 14:13:59
 
Перейти    
Ускорить и упростить код, Есть код, который долго работает, как его облегчить?
 
#
16.03.2023 13:48:40
Добрый день!
Есть 10 файлов, к которым применяется этот код.
Можно ли что-то сделать чтобы он стал быстрее? Загружается около 2 минут.
Помогите, пожалуйста!
Код
Sub Workbook_Open()
Dim arFiles, x, c As Range
Dim iLastRow As Long
Dim A As Range

Application.AskToUpdateLinks = False
Workbooks("Основной").Sheets("Расчёт").Range("A5:CO500").Clear

Workbooks.Open Filename:="тут указан путь"
Workbooks("Москва").Sheets("Расчёт").Range("CO5", Cells(Rows.Count, "A").End(xlUp)).Copy

Workbooks("Основной").Sheets("Расчёт").Activate
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("Москва").Close True

End Sub
 
Перейти    
Отзывы о работодателях и исполнителях, Посмотрите, прежде чем взять/предложить работу
 
#
16.03.2023 13:13:10
Хочу поблагодарить Апострофф за сотрудничество
Решение моего вопроса было готово ранее оговоренного срока
Уже неоднократно сотрудничали. Понимает даже мои не совсем понятные объяснения)
Выполнено всё отлично, еще раз спасибо :*  
Изменено: An_2020 - 28.03.2023 08:28:53 (Дополнить информацию)
 
Перейти    
Страницы: 1 2 След.
Наверх