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

Страницы: 1 2 3 4 5 След.
Удаление пустых подкаталогов в родительском каталоге., Очистка каталога от подкаталогов без файлов
 
Андрей VG, Благодарю, работает! Буду вникать :)  
Удаление пустых подкаталогов в родительском каталоге., Очистка каталога от подкаталогов без файлов
 
Добрый день!
Код ниже удаляет пустые каталоги в указанном родительском.
Как доработать макрос, чтобы удаление производилось на всю
глубину вложенности подкаталогов. В приложенной структуре
каталогов должны удалиться каталоги 2 и 5.
Код удаляет только пустой подкаталог 2 с первого уровня
вложенности. Пустым считать каталог без файлов.

Код
Sub DeleteEmptySubfolders()
    Dim FSO, Folder, Subfolder As Object
    Dim FolderPath, UserName As String
    UserName = Environ("USERNAME")
    FolderPath = "C:\Users\UserName\Desktop\ÒÅÑÒ_\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(FolderPath)

    For Each Subfolder In Folder.SubFolders
        If FSO.GetFolder(Subfolder.path).Files.Count = 0 Then
            Subfolder.Delete
        End If
    Next

    Set FSO = Nothing
    Set Folder = Nothing
    Set Subfolder = Nothing
End Sub

Изменено: aesp - 19.01.2024 11:50:41
Дубли значений ячеек, начиная со второго, Отобразить признак дублированного значения ячейки в столбце, начиная с второго
 
Евгений Смирнов, принято. В массиве даже круче, благодарю ;)  
Дубли значений ячеек, начиная со второго, Отобразить признак дублированного значения ячейки в столбце, начиная с второго
 
Дмитрий(The_Prist) Щербаков, благодарю, вникну!
Тема закрыта.
Дубли значений ячеек, начиная со второго, Отобразить признак дублированного значения ячейки в столбце, начиная с второго
 
mimoprohodil, благодарю, круто)
Дубли значений ячеек, начиная со второго, Отобразить признак дублированного значения ячейки в столбце, начиная с второго
 
mimoprohodil,  для случая с 5ю строками - соглашусь. Однако, для таблиц в несколько сотен тысяч строк, - с формулами машина умрёт. :)  
Дубли значений ячеек, начиная со второго, Отобразить признак дублированного значения ячейки в столбце, начиная с второго
 
Доброго дня!
Есть рабочий код, который выявляет дубли значений ячеек в столбце. Помогите, пожалуйста, модифицировать код: нужно  для каждой группы дубликатов отображать признак "дубль", но только, начиная со второго значения ( т.е. все, кроме первого). В примере подсветил, как должно быть.

Код
Sub HighlightDuplicates()

Dim rng, cell As Range

Set rng = ActiveWorkbook.Sheets("дубли").Range("A1:A100")

For Each cell In rng.Cells

    If Application.WorksheetFunction.CountIf(rng, cell.Value) > 1 And cell.Value <> "" Then

        cell.Offset(0, 1).Value = "дубль"

    End If

Next cell

End Sub
Редактирование тегов внутри файла XML
 
webley, благодарю! Очень помогли!

Вот собрал код по обработке ВСЕХ .xml файлов в указываемом каталоге:

Код
Sub Edit_all_XML_from_Folder()
    '
    Dim sFolder, sFiles As String
    Dim fso As New FileSystemObject, fl As File, fls As TextStream
    '
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xml")
    Do While sFiles <> ""
        Set fl = fso.GetFile(sFolder & sFiles)
        'действия с файлом
        sFiles = Replace(fl.OpenAsTextStream(ForReading).ReadAll, "<value status=""0"">", "<value>") ' в кавычках указываем то, что меняем и на что меняем
        Set fls = fl.OpenAsTextStream(ForWriting)
        fls.Write sFiles
        fls.Close
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Файлы .xml отредактированы!", , "я проверил)"
    '
End Sub
Редактирование тегов внутри файла XML
 
Здравствуйте!
Необходимо макросом отредактировать группу файлов . xml из каталога (пример одного файла прилагаю): заменить все теги <value status="0"> на <value>.
Разумеется, все изменения нужно сохранить при закрытии файла.
Вроде подходящий фрагмент кода на форумах нашёл, однако, не работает. Библиотеку "Microsoft XML, 3.0" подключил. Прошу помощи в допиливании.


Код
Sub Replace_in_XML()
Dim TheFolder, TheFiles, AFile
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TheFolder = fso.GetFolder("C:\Users\Desktop\Каталог\") ' путь к каталогу с xml
Set TheFiles = TheFolder.Files
For Each AFile In TheFiles
ReadXML (AFile)
Next
End Sub
Sub ReadXML(af As String)
Dim xml_doc As New DOMDocument
Dim nde_test As IXMLDOMElement
xml_doc.Load af
For Each nde_test In xml_doc.SelectNodes("<value status=""0"">")
  Debug.Print nde_test.SelectSingleNode("<value>").Text
Next
End Sub
Изменено: aesp - 14.10.2022 06:04:00
Поиск дубликатов файлов в каталогах (подкаталогах) и переименование дублей
 
Ігор Гончаренко, от души! Благодарствуете! Очень помогли - код отрабатывает так, как нужно.
Поиск дубликатов файлов в каталогах (подкаталогах) и переименование дублей
 
RAN, благодарю за ссылки. Перечень всех файлов в каталогах умею создавать - Николай Павлов четко показал.. Не нахожу (мб не вижу) способ переименования 2го, 3го и  т.д. файла в группе одинаковых наименований. Пожалуйста, ткните носом)
Поиск дубликатов файлов в каталогах (подкаталогах) и переименование дублей
 
Добрый вечер!

Прошу такой помощи по VBA, т.к. не смог найти решение в инете:
в структуре связанных каталогов могут находится дубликаты наименований файлов. Дублей может быть несколько в разных каталогах. Задача, указав родительский каталог, исключить дубли наименований, переименовав автоматически дубликаты, добавив к наименованию второго файла числовой индекс, например "Имя(2)", третьему "Имя(3)" и т.д. Первое имя из группы дублей оставить без изменения. Содержимое и размер дублей не анализировать.
Пример каталогов с файлами показываю.

Полное имя файла Путь
1.txt                         C:\Users\admin\Desktop\Каталог1\1.txt
2.txt                   C:\Users\admin\Desktop\Каталог1\2.txt
3.txt                 C:\Users\admin\Desktop\Каталог1\3.txt
3.txt                       C:\Users\admin\Desktop\Каталог1\Каталог2\3.txt
1.txt                        C:\Users\admin\Desktop\Каталог1\Каталог2\Каталог3\1.txt
2.txt                       C:\Users\admin\Desktop\Каталог1\Каталог2\Каталог3\2.txt
4.txt                       C:\Users\admin\Desktop\Каталог1\Каталог2\Каталог3\4.txt
Как "отловить" невидимое содержимое в ячейках
 
msi2102, Jack Famous, благодарю, изучу.
Как "отловить" невидимое содержимое в ячейках
 
Добрый день!
В примере в пустых с виду ячейках есть содержимое, о чём указывает результат формулы СЧЁТЗ. Как узнать какой именно символ (ы) внутри? Как автоматически очищать такие псевдо пустые ячейки, ведь они могут идти не подряд?
Изменено: vikttur - 11.08.2021 16:12:53
Получить итог сводной таблицы по строкам исходной без подсчёта дубликатов значений
 
mechanix 85, Vik_tor, благодарю!
Попарная нумерация строк
 
А1=1
А2=А1
Далее захватить две ячейки и протянуть (стандарно) вниз за правый нижний квадратик диапазона.
Получить итог сводной таблицы по строкам исходной без подсчёта дубликатов значений
 
Доброго дня!

        В примере: есть позиции (стол, стул) и номера заявок (ABS00000). По каждой позиции могут быть несколько разных заявок, которые выполняют разные люди.
Сводная подсчитала 14 заявок, однако, уникальных всего 10. Результат должен = 10.
        Прошу помощи: как без макроса с помощью сводной таблицы получить итоги за исключением дубликатов заявок в разрезе позиций?
Изменено: vikttur - 11.07.2021 09:36:30
Превращение текста в ячейке в формулу макросом
 
RAN, благодарю! Смутно догадывался в чём причина, но не знал, как реализовать!
Тема закрыта! Всем спасибо)

Код
Sub q()
'
'ГОТОВО!превращение в ФОРМУЛу
ThisWorkbook.Sheets("1").Range("AI3").FormulaLocal = "=" & ThisWorkbook.Sheets("1").Range("AI3")

End Sub
Превращение текста в ячейке в формулу макросом
 
vikttur, это нормально, просто в примере нет данных для формулы (пустые ячейки). Проблема в остановке макроса с ошибкой, которую указал выше.
Изменено: aesp - 29.05.2021 13:47:58
Превращение текста в ячейке в формулу макросом
 
vikttur, сорри, вот второй пример. Проверил несколько раз. Установка знака равно вручную в формулу превращает!
Изменено: aesp - 29.05.2021 13:11:00
Превращение текста в ячейке в формулу макросом
 
БМВ, будьте добры, помогите дальше)
Вставил в пример длинную формулу - не работает (ошибка: run-time error 1004 application defined or object defined).
Код
Sub q()
     Range("AI3").Formula = "=" & Range("AI3")
End Sub

Та же ошибка этого варианта в случае длинной формулы(
Код
Sub q()
     ThisWorkbook.Sheets("1").Range("AI3").Formula = "=" & ThisWorkbook.Sheets("1").Range("AI3")
     'ThisWorkbook.Sheets("1").Cells(3, 35).Formula = "=" & ThisWorkbook.Sheets("1").Cells(3, 35)
End Sub
Превращение текста в ячейке в формулу макросом
 
БМВ, от души!
Работает:

Код
Sub q()
'
' замена на формулу
'
Range("C1").Formula = "=" & Range("C1")
'
End Sub
Превращение текста в ячейке в формулу макросом
 
Здравствуйте!
Подскажите, пожалуйста, есть ли возможность посредством макроса (нужно именно макросом!) заменить текст в ячейке на формулу. Записанный макрорекордером код не отрабатывает при запуске.
Нужно, например, текст в ячейке С1 "А1+В1" (без кавычек) заменить макросом на формулу =А1+В1
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
Дмитрий(The_Prist) Щербаков,
Цитата
Дмитрий(The_Prist) Щербаков написал:
перебрать все папки и подпапки, не зная для них всех точные пути, невозможно
- пОнято! Благодарю!
Тема закрыта)
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
Дмитрий(The_Prist) Щербаков, верное замечание! Конечно же
Цитата
Дмитрий(The_Prist) Щербаков написал:
Так задумано?
- это "оплошность")  И благодарю за оптимизацию кода!
Однако, хотелось бы, всё-таки, найти способ выполнения одним кодом, без
Цитата
Дмитрий(The_Prist) Щербаков написал:
применен рекурсивный вызов функции
.... :)
Изменено: aesp - 11.02.2021 14:57:27
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
RAN, БМВ, Дмитрий(The_Prist) Щербаков, можете помочь в этой задаче? Если платно, напишите в личку ;)
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
Дмитрий(The_Prist) Щербаков, убрал On Error Resume Next: код отрабатывает также "на ура".
Замена цикла на одну строку, как Вы посоветовали, даёт останов на этой строке...
В общем, как понимаю, нет приемлемого пути внедрения такого алгоритма в надстройку, спасибо..
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
спасибо, приму к сведению.
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
Уважаемый, Дмитрий(The_Prist) Щербаков, цель засунуть код в надстройку и запуск через кнопку на форме. Запускается, но вторая часть не работает..
Поиск и перемещение всех файлов XLS* в отдельный каталог
 
Доброго дня!
Есть рабочий модуль, состоящий из двух связанных макросов. Модуль позволяет переместить (собрать)все файлы с расширением XLS* из каталогов любой вложенности в каталог ИТОГ на рабочем столе. Задача: помогите сделать один макрос из этих двух частей, выполняющий точно такую задачу. Тестовые файлы прилагаю. Благодарю!

Код
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Get_XLS_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
    MsgBox "Файлы 'выдернуты' из всех указанных каталогов", vbInformation, "Гарантирую!"
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName, UserName As String
    Dim wb As Workbook
    UserName = Environ("USERNAME")
    If Dir("C:\Users\" & UserName & "\Desktop\ИТОГ\", vbDirectory) = "" Then
    MkDir "C:\Users\" & UserName & "\Desktop\ИТОГ\"
    End If
    If Dir("C:\Users\" & UserName & "\Desktop\ИТОГ\XLS\", vbDirectory) = "" Then
    MkDir "C:\Users\" & UserName & "\Desktop\ИТОГ\XLS\"
    End If
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'On Error Resume Next
            objFSO.MoveFile objFolder & "\*.xls*", "C:\Users\admin\Desktop\ИТОГ\XLS\"
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub
Изменено: aesp - 11.02.2021 05:39:53
Страницы: 1 2 3 4 5 След.
Наверх