Цикл Excel / VBA выполняется только для первого файла

Question

У меня есть около 100 .xls файлов в одной папке, и у меня есть макрос-скрипт для циклического просмотра каждого из них для некоторой обработки данных.Цель состоит в том, чтобы разбить каждую книгу на три с именами N1, N2, N3 соответственно.Пока что мой SplitData макрос работал нормально, но у меня проблема с извлеченными книгами.

Я хочу объединить только что извлеченные три книги с уже существующими вместо того, чтобы получать оповещения типа «Файл N1 уже существует».каждый раз.Я изменил Application.DisplayAlerts = false из-за предложенного ответа на мой предыдущий вопрос, но теперь я получил новую ошибку:

После того, как предупреждение отключено, мои первые две извлеченные книги продолжают обновлять тот же результат из первой книги, которую я начал извлекать, покатретий заперт в цикле, добавляя тот же результат из начальной книги.Я предполагаю, что с моим циклом что-то не так, но не могу его найти, может кто-нибудь помочь мне проверить, пожалуйста?

Большое спасибо!

Это мой код для циклического просмотра папки:

Sub OpenFiles()
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    xFile = Dir(xStrPath & "\*.xls")

    Do While xFile <> ""
        Call SplitData
    Loop
End Sub

Это макрос SplitData:

Sub SplitData()
 ' 1. Fill every cells in merged columns for future steps
            Dim cell As Range, joinedCells As Range

            For Each cell In Range("E4:I60")
                If cell.MergeCells Then
                    Set joinedCells = cell.MergeArea
                    cell.MergeCells = False
                    joinedCells.Value = cell.Value
                End If
            Next


            ' 2. Split original sheet into three based on one col value 
            ' loop through selected column to check if has different values
            Const NameCol = "B"
            Const HeaderRow = 3
            Const FirstRow = 4
            Dim SrcSheet As Worksheet
            Dim TrgSheet As Worksheet
            Dim SrcRow As Long
            Dim LastRow As Long
            Dim TrgRow As Long
            Dim Student As String
            Application.ScreenUpdating = False
            Set SrcSheet = ActiveSheet
            LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
            For SrcRow = FirstRow To LastRow
                Student = SrcSheet.Cells(SrcRow, NameCol).Value
                Set TrgSheet = Nothing
                On Error Resume Next
                Set TrgSheet = Worksheets(Student)
                On Error GoTo 0
                If TrgSheet Is Nothing Then
                    Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    TrgSheet.Name = Student
                    SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
                End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
            Next SrcRow
            Application.ScreenUpdating = True


            ' 3. Extract three new worksheets into three workbooks 
            Dim Pointer As Long

            Set MainWorkBook = ActiveWorkbook
            Range("E4").Value = MainWorkBook.Sheets.Count

            Application.ScreenUpdating = False   'enhance the performance
            For Pointer = 2 To MainWorkBook.Sheets.Count
                Set NewWorkbook = Workbooks.Add
                MainWorkBook.Sheets(Pointer).Copy After:=NewWorkbook.Sheets(1)
                Application.DisplayAlerts = False
                NewWorkbook.Sheets(1).Delete
                Application.DisplayAlerts = False
                With NewWorkbook
                    .SaveAs Filename:="D:\***\Inventory\" & MainWorkBook.Sheets(Pointer).Name & ".xls"
                End With
                NewWorkbook.Close SaveChanges:=True
            Next Pointer

            Application.ScreenUpdating = True

End Sub

Answer 1

Кажется, нужно открыть и закрыть файл.

Sub OpenFiles()
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    xFile = Dir(xStrPath & "\*.xls")

    Dim Wb As Workbook
    Do While xFile <> ""
        Set Wb = Workbooks.Open(Filename:=xStrPath & "\" & xFile) '<~~ open file
        Call SplitData
        Wb.Close (0) '<~~ close file
        xFile = Dir '<~~ re dir
    Loop
End Sub

Answer 2

Вам нужно добавить xFile = Dir в ваш цикл для циклического перемещения по файлам.

...
    xFile = Dir(xStrPath & "\*.xls")

    Do While xFile <> ""
        Call SplitData
        xFile = Dir
    Loop
...

Неясно, как xFile передается в SplitData.Разве SplitData не должен иметь аргумент, который получает xFile?