VBA Макросы: Работа со всеми xml файлами в папке.

[Quasi]

Есть работающий макрос, который изменяет строку в конкретно указанном xml файле. Однако таких файлов очень много, поэтому требуется макрос, работающий со всеми xml файлами в папке. Адрес папки известен, все имеющиеся там файлы нужно обработать таким образом.

Операционная система: Windows 7.

Макрос

Public Sub ReplaceStringInFile()

Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
Dim sFileName As String

'Путь к файлу
sFileName = "C:\Users\User\Desktop\1\80020_0264004103_20190630_215_0000000001.xml"
   
iFileNum = FreeFile
Open sFileName For Input As iFileNum

Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum

sTemp = Replace(sTemp, "<daylightsavingtime>1</daylightsavingtime>", "<daylightsavingtime>0</daylightsavingtime>")

iFileNum = FreeFile
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
   
End Sub

[свернуть]

[Администратор]

1. Это код для виндоуса. Для мака нужно писать другой код.

2. Вверху модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

3. Подключите библиотеку:
Tools - References... - Microsoft Scripting Runtime

4. В процедуре "ПолучитьПолныеИмена":
1) в пункте 2 укажите полное имя (путь + имя) папки, которую надо просмотреть. На конце слеш не указывайте;
2) в пункте 4, справа от "Case" укажите нужные расширения через запятую, как сейчас сделано.

Макрос

Sub Макрос()

    Dim FNs As Collection
    Dim i As Long
   
   
    '1. Записываем в коллекцию "FNs" полные имена файлов, которые находятся
        ' в указанной папке
    ПолучитьПолныеИмена FNs
   
    '2. Работа с файлами.
    For i = 1 To FNs.Count
        ReplaceStringInFile FNs(i)
    Next i

    '3. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub ПолучитьПолныеИмена(FNs As Collection)

    Dim fso As Scripting.FileSystemObject
    Dim папка As Scripting.Folder, файл As Scripting.File
   
   
    '1. Создание объекта, который умеет работать с папками и файлами.
    Set fso = New FileSystemObject
   
    '2. Присваиваем имя папке, с которой надо работать.
    ' Здесь укажите полное имя папки. На конце слеш не нужно указывать.
    Set папка = fso.GetFolder("C:\Users\User\Desktop\Файлы")
   
    '3. Создание коллекции.
    Set FNs = New Collection
   
    '4. Запись в коллекцию полных имён файлов, которые находятся в указанной папке.
        ' Если эксель-файл открыт, то в папке будет скрытый файл, относящийся к этому файлу.
        ' Поэтому делается проверка, что файл не скрытый.
    For Each файл In папка.Files
        If (файл.Attributes And Hidden) = 0 Then
            Select Case Mid(файл.Name, InStrRev(файл.Name, ".") + 1)
                Case "xlsb", "xlsx"
                    FNs.Add item:=файл.Path
            End Select
        End If
    Next файл
   
End Sub

Private Sub ReplaceStringInFile(FN As String)

    Dim sBuf As String
    Dim sTemp As String
    Dim iFileNum As Integer
   
       
    iFileNum = FreeFile
    Open FN For Input As iFileNum
   
    Do Until EOF(iFileNum)
    Line Input #iFileNum, sBuf
    sTemp = sTemp & sBuf & vbCrLf
    Loop
    Close iFileNum
   
    sTemp = Replace(sTemp, "<daylightsavingtime>1</daylightsavingtime>", "<daylightsavingtime>0</daylightsavingtime>")
   
    iFileNum = FreeFile
    Open FN For Output As iFileNum
    Print #iFileNum, sTemp
    Close iFileNum
   
End Sub

[свернуть]

[Quasi]

Благодарю, все работает!