Т.е. на самый первый файл номер не ставится, потому что если файл только один, то номер как бы не нужен, у меня такой вариант получился. Решение не универсальное, а исключительно для данного примера от Лилиенталь. Возможно код от уважаемого МатросНаЗебре, решит задачу Лилиенталь одним махом.
Код, может кому интересно
Код
Sub Rename_File()
Dim sFilePath As String, LastRow As Long, i As Long, myDict As Object
Dim Cell As Range, oldName As String, newName As String
sFilePath = Split(Range("A1").Text, " ", 3)(2) 'путь к текущей паке
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set myDict = CreateObject("Scripting.Dictionary")
For Each Cell In Range("B3:B" & LastRow)
If Not myDict.Exists(Cell.Value) Then
myDict.Add Cell.Value, WorksheetFunction.CountIf(Range("B3:B" & LastRow), Cell.Value)
End If
Next Cell
If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
If Application.WorksheetFunction.CountA(Range("A3:A" & LastRow)) <> Application.WorksheetFunction.CountA(Range("B3:B" & LastRow)) Then Exit Sub
For i = LastRow To 3 Step -1
If Dir(sFilePath & Cells(i, 1).Text, 16) <> "" And _
ThisWorkbook.FullName <> sFilePath & Cells(i, 1).Text And _
ThisWorkbook.FullName <> sFilePath & Cells(i, 2).Text Then
If myDict.Item(Cells(i, 2).Text) > 1 Then
oldName = Cells(i, 1).Text
newName = Mid(Cells(i, 2).Text, 1, InStrRev(Cells(i, 2).Text, ".")) & "(" & _
myDict.Item(Cells(i, 2).Text) & ")" & _
Mid(Cells(i, 2).Text, InStrRev(Cells(i, 2).Text, "."))
myDict.Item(Cells(i, 2).Text) = myDict.Item(Cells(i, 2).Text) - 1
'переименовываем файл(сo счётчикoм)
Name sFilePath & oldName As sFilePath & newName
Else
'просто переименовываем файл(без счётчика)
Name sFilePath & Cells(i, 1).Text As sFilePath & Cells(i, 2).Text
End If
End If
Next i
'Update file list
Call ListFilesInFolder(sFilePath)
Shell "explorer.exe " & sFilePath, vbNormalFocus
End Sub
В словаре в Key записываем все новые имена файлов и в Item через СЧЁТЕСЛИ их количество в заданном диапазоне...
У Вас получается переменная Vsego увеличивается только когда выполняется условие(=150), так оно(Vsego) по моему должно быть вообще в конце снизу... Вот мои попытки:разделение контрактов.xlsm(24.62 КБ), но это вроде еще не то что нужно.
Цитата
maksvsh написал: Постарался обозначить в файле, чтобы понятно было.
Не очень оно то и понято. Формулу первую куда? Вторую? P.S. Лучше бы вручную сделать два листа, первый — исходник, типа как было изначально, а второй — как должно получиться в результате.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'ThisWorkbook.Unprotect "123"
'ищем последнюю занятую строчку в логах
lastrow = Worksheets("Лог").Range("A60000").End(xlUp).Row
'заносим дату-время выхода из файла
If lastrow > 1 Then Worksheets("Лог").Cells(lastrow, 3) = Now
'скрываем все листы, кроме листа ПРЕДУПРЕЖДЕНИЕ
Worksheets("Предупреждение").Visible = True
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Предупреждение" Then
sh.Visible = True
Else
sh.Visible = xlSheetVeryHidden
End If
Next sh
'сохраняемся перед выходом
'Тот самый код, просто поменял строки местами
ThisWorkbook.Protect Password:="123", Structure:=True, Windows:=True
ActiveWorkbook.Save
End Sub
Private Sub Workbook_Open()
ThisWorkbook.Unprotect Password:="123"
'ищем последнюю занятую строчку в логах
lastrow = Worksheets("Лог").Range("A60000").End(xlUp).Row
'заносим имя пользователя и дату-время входа в файл
Worksheets("Лог").Cells(lastrow + 1, 1) = Environ("USERNAME")
Worksheets("Лог").Cells(lastrow + 1, 2) = Now
'отображаем все листы
For Each sh In ActiveWorkbook.Worksheets
sh.Visible = True
Next sh
'скрываем листы ПРЕДУПРЕЖДЕНИЕ и ЛОГ
Worksheets("Предупреждение").Visible = xlSheetVeryHidden
Worksheets("Лог").Visible = xlSheetVeryHidden
End Sub
Этот код делает как-раз то - что Вы на скрине показывали.
Код
ThisWorkbook.Protect...
ThisWorkbook.Unprotect...
Получается что только первый раз приходится включать макросы, второй - содержимое, а потом все автоматом включается.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'ищем последнюю занятую строчку в логах
lastrow = Worksheets("Лог").Range("A60000").End(xlUp).Row
'заносим дату-время выхода из файла
If lastrow > 1 Then Worksheets("Лог").Cells(lastrow, 3) = Now
'скрываем все листы, кроме листа ПРЕДУПРЕЖДЕНИЕ
Worksheets("Предупреждение").Visible = True
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Предупреждение" Then
sh.Visible = True
Else
sh.Visible = xlSheetVeryHidden
End If
Next sh
'сохраняемся перед выходом
ActiveWorkbook.Save
ThisWorkbook.Protect "123", True, True
ThisWorkbook.Password = "123"
End Sub
Private Sub Workbook_Open()
ThisWorkbook.Unprotect "123"
'ищем последнюю занятую строчку в логах
lastrow = Worksheets("Лог").Range("A60000").End(xlUp).Row
'заносим имя пользователя и дату-время входа в файл
Worksheets("Лог").Cells(lastrow + 1, 1) = Environ("USERNAME")
Worksheets("Лог").Cells(lastrow + 1, 2) = Now
'отображаем все листы
For Each sh In ActiveWorkbook.Worksheets
sh.Visible = True
Next sh
'скрываем листы ПРЕДУПРЕЖДЕНИЕ и ЛОГ
Worksheets("Предупреждение").Visible = xlSheetVeryHidden
Worksheets("Лог").Visible = xlSheetVeryHidden
End Sub
Изменено: DANIKOLA - 05.04.2024 10:57:40(Код спрятал в спойлер)
С файлом-примером было бы проще... Код с картинки я переписывать не буду и плюс откуда мне знать каким способом Вы решили сделать защиту, или книгу полностью, или отдельный лист...
Та вроде все логично, в защищенной книге ведь лист нельзя скрыть или показать вручную, а здесь это пытается сделать макрос — вот и конфликт получается. Решение: снимаем защиту программно, потом выполняем все остальные операции и ставим защиту обрано(тоже программно).
И Вам спасибо за быстрые ответы, а то есть люди, которые могут ответить примерно через неделю. И что с такими темпами можно решить, когда оно(объяснение) вот сейчас нужно... Всего хорошего. Пока.
Вроде понял, но возможно не все... Вариант3 с выпадающим списком для избежания ошибок ввода №. __ P.S. Флажки криво работают, жмешь один реагируют два, проверьте все, исправьте...
И это более наглядно покажите в файле или объясните здесь, как оно должно работать. И какой там номер будет меняться? Показали бы нормально в файле-примере и плюс детальнее описать, так уже бы сделал(ли), а так приходится Вас допрашивать за каждую деталь, что не очень то интересно... ____ UPD: Или может так должно получиться?
Код
Код
Sub copyChecked()
Dim i&, j&, lastRow&, nextEmptyCol&
lastRow = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
j = 1
For i = 4 To lastRow
If Worksheets("Лист1").Cells(i, 3).Value <> "" Then j = j + 1
nextEmptyCol = Worksheets("Лист2").Cells(j, Columns.Count).End(xlToLeft).Column + 1
If Worksheets("Лист1").Cells(i, 3).Value = True Then
Worksheets("Лист1").Cells(i, 3).Copy
Worksheets("Лист2").Cells(j, nextEmptyCol).PasteSpecial Paste:=xlPasteValues
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Worksheets("Лист2").Activate
End Sub
Sub copyChecked()
Dim i&, lastRow&, nextEmptyRow&
lastRow = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = 4 To lastRow
nextEmptyRow = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row + 1
If Worksheets("Лист1").Cells(i, 3).Value = True Then
Range(Worksheets("Лист1").Cells(i, 1), Worksheets("Лист1").Cells(i, 3)).Copy
Worksheets("Лист2").Cells(nextEmptyRow, 1).PasteSpecial Paste:=xlPasteValues
With Worksheets("Лист2").Range("A" & nextEmptyRow & ":I" & nextEmptyRow).Borders
.LineStyle = xlContinuous
.Weight = xlHairline
End With
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Worksheets("Лист2").Activate
End Sub
Из столбца с названием предприятия и несколькими его адресами извлечь с повтором название предприятия., Помощь при обработке данных Excel/Данные таблицы Excel
Sub FixTable()
Dim lastRow As Long, i As Long, rngTemp As Range, newWsh As Worksheet
lastRow = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
Set newWsh = ActiveWorkbook.Worksheets.Add(After:=Worksheets("Лист1"))
Application.ScreenUpdating = False
For i = 1 To lastRow
If Worksheets("Лист1").Cells(i, 1).IndentLevel = 0 Then
Set rngTemp = Worksheets("Лист1").Cells(i, 1)
End If
If Worksheets("Лист1").Cells(i, 1).IndentLevel = 0 Then
rngTemp.Copy Range(newWsh.Cells(i, 1), newWsh.Cells(i, 2))
ElseIf Worksheets("Лист1").Cells(i, 1).IndentLevel = 1 Then
rngTemp.Copy newWsh.Cells(i, 1)
Worksheets("Лист1").Cells(i, 1).Copy newWsh.Cells(i, 2)
End If
Next i
newWsh.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub MainMacro()
With Worksheets("Лист1")
ClearRg .Cells.Find("мин", , xlValues, xlWhole, SearchFormat:=False)
ClearRg .Cells.Find("макс")
End With
End Sub
Sub ClearRg(rg As Range)
If rg Is Nothing Then Exit Sub
rg.EntireColumn.FormatConditions.Delete
rg.Resize(4, 1).ClearFormats' Эта строчка!
'rg.Resize(4, 1).ClearContents
End Sub
Написать формулу в новом столбце, в котором будет выдаваться текст «60+», если сотруднику на сегодняшний день больше 60 лет., В противном случае нужно оставлять ячейку пустой
Доброго и Вам. Код срабатывает при изменении диапазона "A1:B1". Код нужно скопировать в модуль листа, на котором Вам нужна автоматическая вставка колонтитула из заданных ячеек. Вот он, модуль листа:, двойной клик и туда копируем код.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:B1")) Is Nothing Then Exit Sub
With ActiveSheet.PageSetup
.OddAndEvenPagesHeaderFooter = True
.DifferentFirstPageHeaderFooter = True
'Для 1-й и всех нечётных страниц из ячейки "A1"
.FirstPage.CenterHeader.Text = Range("A1").Value
.FirstPage.RightFooter.Text = Range("A1").Value
'Для всех чётных страниц из ячейки "B1"
.EvenPage.CenterHeader.Text = Range("B1").Value
.EvenPage.LeftFooter.Text = Range("B1").Value
End With
End Sub
Возможно не совсем то что Вам нужно, но направление Вам задаст. _____ UPD:
Цитата
gordeev-pro написал: уточнить возможности MS Excel в части возможности присвоения значения в колонтитул на конкретную указанную в коде страницу например 39 страницу
Не нашел такой возможности.
Изменено: DANIKOLA - 19.03.2024 20:51:00(Добавил ответ на сообщение №4)
sashamesher написал: ...с именем идентичным названием папки в которой находится файл...
Ну если файл только один, то можно прям таки идентичным, но если больше одного, то никак не получится, файлы ведь не могут быть с одинаковыми именами. Или подробнее объясните, каким Вы видите решение. Вот подправил код, к началу имени файла(ПДФ) прикрепляется имя папки в которой он находится. Вот так получается ==>
Код
Sub DocxToPDF_WithFolderName()
Dim objDoc As Document
Dim strFile As String, strFolderPath As String, strFolderOnly As String
Application.ScreenUpdating = False
strFolderPath = Application.ActiveDocument.Path & Application.PathSeparator
strFolderOnly = Split(strFolderPath, "\")(UBound(Split(strFolderPath, "\")) - 1)
strFile = Dir(strFolderPath & "*.docx", vbNormal)
While strFile <> ""
Set objDoc = Documents.Open(FileName:=strFolderPath & strFile)
objDoc.ExportAsFixedFormat _
OutputFileName:=strFolderPath & strFolderOnly & "_" & Mid(strFile, 1, Len(strFile) - 5) & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
objDoc.Close
Set objDoc = Nothing
strFile = Dir()
Wend
Application.ScreenUpdating = True
'Application.Quit
End Sub
Цитата
sashamesher написал: или с возможностью вбивать имя файла вручную
И этот вариант тоже объясните, для случая когда несколько файлов, сделать не проблема, вопрос только, как именно Вы хотите... _______ UPD: Вы отписались спустя почти неделю, та еще переписка, так и не объяснив "каким Вы видите решение...", в случае если файлов будет много. Прикрутить кусок кода не трудно, Вы только скажите или покажите, как должен выглядеть конечный результат. _______ P.S. И про Excel здесь как-то маловато, форум(та и сайт полностью) ведь специализируется именно по Excel-ю, а не по Word-y.
Может так? Только нужно выделять картинки полностью, особенно чтобы захватывало верхний левый угол(TopLeftCell).
Код
Sub SavePicturesOfSel()
Dim i As Long, txtFolderPath As String, strFileName As String, selRange As Range, Hypotenuse As Double
txtFolderPath = ActiveWorkbook.Path
If ActiveSheet.Shapes.Count = 0 Then
MsgBox "А картинок то нету!"
Exit Sub
End If
If TypeName(Selection) <> "Range" Then
Exit Sub
Else
Set selRange = Selection
End If
If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete
For i = 1 To ActiveSheet.Shapes.Count
'If ActiveSheet.Shapes(i).Type = 13 Then 'MsoShapeType.msoPicture(если только картинки)
If Not Intersect(ActiveSheet.Shapes(i).TopLeftCell, selRange) Is Nothing Then
ActiveSheet.Shapes(i).Copy
strFileName = ActiveSheet.Shapes(i).Name
With ActiveSheet.ChartObjects.Add(0, 0, ActiveSheet.Shapes(i).Width, ActiveSheet.Shapes(i).Height).Chart
DoEvents
If ActiveSheet.Shapes(i).Rotation > 0 Then
Hypotenuse = Sqr(ActiveSheet.Shapes(i).Width ^ 2 + ActiveSheet.Shapes(i).Height ^ 2)
.ChartArea.Width = Hypotenuse
.ChartArea.Height = Hypotenuse
End If
.ChartArea.Select
.Paste
.Shapes(1).Left = (.ChartArea.Width - .Shapes(1).Width) / 2
.Shapes(1).Top = (.ChartArea.Height - .Shapes(1).Height) / 2
.Export Filename:=txtFolderPath & "\" & strFileName & ".jpg"
.Parent.Delete
End With
End If
'End If
Next i
selRange.Select
'Открыть папку с картинками
Shell "explorer.exe " & txtFolderPath, vbMaximizedFocus
End Sub
Только с повернутым треугольником получается такое:
____ UPD: Вроде решил проблему с повернутым треугольником.
Дмитрий Сомов, нету разницы что там будет, если есть совпадение значения ячейки с одним из списка(Case "Понедельник"...), то выполнится тот же самый кусок кода. Можно список понимать так: Case "Понедельник", или "Вторник", или "Среда", и.т.д.
Цитата
Дмитрий Сомов написал: Как проще выйти из положения ?
Не знаю, из описания не совсем понятно, что вообще нужно...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range, WSh2 As Worksheet
If Intersect(Target, Range("A1")) Is Nothing Then End
Set WSh2 = Worksheets("Лист2")
Set myRange = WSh2.Range(WSh2.Range("A5"), WSh2.Range("A5").End(xlDown).End(xlToRight))
Select Case Range("A1").Text
Case "Понедельник", "Вторник", "Среда", "Четверг", "Пятница", "Суббота", "Воскресенье"
myRange.AutoFilter Field:=1, Criteria1:=Worksheets("Лист1").Range("A1").Text
Case "Все"
On Error Resume Next: Worksheets("Лист2").ShowAllData: On Error GoTo 0
End Select
End Sub
Цитата
Дмитрий Сомов написал: Но есть нюансы, которые указал наглядно, в прикрепленном файле.
Об этих нюансах лучше в самом начале говорить, а не ждать пока кто-нибудь решит Вашу задачу, но из-за нюансов это решение будет не совсем правильным. _______ UPD:
Цитата
Дмитрий Сомов написал: ...то достаточно заменить все значения "A1", а их в коде ТРИ, на ту ячейку, где будет мой список ?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A5000")) Is Nothing Then
'если это номер договора (есть слеш /) - не делать ничего
If InStr(1, Target, "/") > 0 Then Exit Sub
'если это трёхзначное число - выполнить макрос ZapIpso
If Len(Target) = 3 Then
Call ZapIpso
'если это число более трёх знаков - выполнить макрос Spacing
ElseIf Len(Target) > 3 Then
Call Spacing
End If
End If
End Sub
Цитата
macovea написал: Сами макросы собраны и работают отлично
В самих макросах есть проблемы: Range(ActiveCell.Offset(0, -1)... А ActiveCell - это уже столбец "А" влево от него не сместишься выходит ошибка или это файл-пример кривой.
Код в модуль листа в котором выбираются дни недели:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then End
With Worksheets("Лист2")
.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=Worksheets("Лист1").Range("A1").Text
End With
End Sub
Здравствуйте. Очевидно что поиск(и фильтр наверное) работают только с видимыми ячейками, перед каждым Вашим макросом в сводном макросе добавлена строка "Очистить фильтр для столбца...", получена(строка кода) из макрорекордера, вроде работает. ___ UPD:
Код
Sub OneFilter(ByVal crit As Variant, Result As Range)
ActiveSheet.Range("$A$13:$O$3057").AutoFilter Field:=6
If Not Columns(6).Find(what:=crit) Is Nothing Then
ActiveSheet.Range("$F$9:$F$3500").AutoFilter Field:=6, Criteria1:=crit
q = Application.WorksheetFunction.Subtotal(3, Range(Cells(9, 6), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 6)))
Result = q
Else
q = 0
End If
MsgBox q
End Sub
Sub Итог()
Application.ScreenUpdating = False
Call OneFilter(Cells(4, 2).Text, Cells(4, 3))
Call OneFilter(Cells(5, 2).Text, Cells(5, 3))
Call OneFilter(Cells(6, 2).Text, Cells(6, 3))
Call OneFilter(Cells(7, 2).Text, Cells(7, 3))
Call OneFilter(Cells(8, 2).Text, Cells(8, 3))
Call OneFilter(Cells(9, 2).Text, Cells(9, 3))
Application.ScreenUpdating = True
End Sub