Sub RenameFoldersInFolders()
Dim parentFolderPath As String
Dim fso As Object
Dim parentFolder As Object
Dim subFolder As Object
Dim newFolderName As String
Dim counter As Integer
' Укажите путь к родительской папке, в которой находятся подпапки
parentFolderPath = "R:\ххххх\_Новая\ПАПКА" ' Измените на путь к вашей родительской папке
' Создаем объект FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Проверяем, существует ли родительская папка
If Not fso.FolderExists(parentFolderPath) Then
MsgBox "Родительская папка не найдена!"
Exit Sub
End If
' Открываем родительскую папку
Set parentFolder = fso.GetFolder(parentFolderPath)
' Счетчик для создания уникальных имен
counter = 1
' Перебираем все подпапки в родительской папке
For Each subFolder In parentFolder.Subfolders
' Пример нового имени папки: "Folder_1", "Folder_2" и так далее
' newFolderName = "Folder_" & counter
CurentName = subFolder.Name
newName = Replace(CurentName, "++", "")
If subFolder.Name <> newName Then subFolder.Name = newName
' Переименовываем папку
' Name parentFolderPath & CurentName as & "\" & newFolderName
' subFolder = parentFolderPath & "\" & newFolderName
' Увеличиваем счетчик
counter = counter + 1
Next subFolder
MsgBox "Переименование папок завершено!"
End Sub
Архив рубрики: Без рубрики
Sub ДвоичныйПоиск()
Sub ДвоичныйПоиск()
txtFind = "01.02.2023"
first = 1
last = 51
Length = 50
half0 = 26
i = 1
Length = first + last
Do While last >= first
half = Round((first + last) / 2)
If Range("B" & half) = CDate(txtFind) Then
For Row = half To 50
If Range("B" & Row) <> CDate(txtFind) Then
xx = Row
Exit For
End If
Next Row
Debug.Print "Кол-во операций: " & i & " последний элемент " & xx - 1
Exit Sub
End If
If Range("B" & half).Value > CDate(txtFind) Then 'Range("B" & half) > txtFind 'DateDiff("d", txtFind, Range("B" & half)) > 0
last = half - 1
Else
first = half + 1
End If
i = i + 1
Loop
Debug.Print "Значение не найдено. Кол-во операций " & i
End Sub
Найти элемент в справочнике
Процедура НайтиГаражНажатие(Элемент)
// Вставить содержимое обработчика.
Если ПустаяСтрока(ТекущееНазвание) тогда
возврат;
конецЕсли;
Гараж = Справочники.спГараж.НайтиПоНаименованию(ТекущееНазвание,Истина);
КонецПроцедуры
Работа с буфером
‘Public Sub SetTextIntoClipboard(ByVal txt As String) ‘ Dim MyDataObj As New DataObject ‘ MyDataObj.SetText txt ‘ MyDataObj.PutInClipboard ‘End Sub Sub SetTextIntoClipboard(ByVal txt$) ‘ Запись в буфер With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText txt$ .PutInClipboard End With End Sub Sub Extract_Unique() Dim Продолжить чтение Работа с буфером
Открыть диалоговое окно
Sub ShowGetOpenDialod() Dim avFiles ‘по умолчанию к выбору доступны файлы Excel(xls,xlsx,xlsm,xlsb) avFiles = Application.GetOpenFilename _ ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы", , True) If VarType(avFiles) = vbBoolean Then ‘была нажата кнопка отмены — выход из процедуры Exit Sub Продолжить чтение Открыть диалоговое окно
CreateObject(«wscript.network»).UserDomain
CreateObject(«wscript.network»).UserDomain
Word надстройки З-н
Sub addTable() Dim wb As Excel.Workbook With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = False .Title = «Выбрать файлы отчетов» ‘заголовок окна диалога .Filters.Clear ‘очищаем установленные ранее типы файлов .Filters.Add «Excel files», «*.xls*;*.xla*», 1 ‘устанавливаем возможность выбора только файлов Excel .FilterIndex = 2 ‘устанавливаем Продолжить чтение Word надстройки З-н
Анализ отчетности v0.1
Sub RunTSP() Set shdto = ActiveWorkbook.Worksheets(1) Set shdfrom = ActiveWorkbook.Worksheets(2) For Each r In Range("KeyStrings") Next r End Sub Function MyFormatMLN(ByVal number As Double) As Variant MyFormatMLN = FormatNumber(number / 1000, 2) & " млн. руб." Продолжить чтение Анализ отчетности v0.1
Поиск квартала
Function GetQQQ(rn As Range) As Variant Dim arr(1, 1) As String arr(0, 0) = «Оборотно-сальдовая ведомость по счету » For i = 0 To UBound(arr, 2) If Not rn.Find(arr(0, i)) Is Nothing Then If i = 0 Then GetQQQ = Продолжить чтение Поиск квартала
Уникальные дубликаты
Sub getTheSame() On Error GoTo errh: ‘Устанавливаем хендлер ошибок Set h = CreateObject("Scripting.dictionary") ‘Создаем хеш — множество пар "ключ" -> значение Dim rg As Range Count = 0 ReDim avArr(1 To Rows.Count, 1 To 2) ReDim tempArr(1 To 10) j Продолжить чтение Уникальные дубликаты