Вызов одной подпрограммы из другой

Question

Я пытаюсь распаковать и скопировать данные для папки с файлами xlsx.

Отдельно оба макроса работают по назначению.Когда я объединяю макросы (через «Вызов»), он выполняется, но затем возвращает меня к экрану макросов.Это не дает мне никаких ошибок, но мне нужно закрыть Excel, чтобы начать все сначала.

Я предполагаю, что макрос "UnMergeFill" не подходит для автоматического открытия?

Я пытался использовать "вызов", а также только с именем сабвуфера.Я также попытался разделить сабвуферы на разные модули.

Sub AllWorkbooks()

   Dim MyFolder As String
   Dim MyFile As String
   Dim wbk As Workbook

On Error Resume Next

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Please select a folder"

.Show

.AllowMultiSelect = False

   If .SelectedItems.Count = 0 Then

MsgBox "You did not select a folder"

      Exit Sub

   End If

MyFolder = .SelectedItems(1) & "\"

End With

MyFile = Dir(MyFolder)

Do While MyFile <> “”

   Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)


UnMergeFill


wbk.Close savechanges:=True

MyFile = Dir

Loop

Application.ScreenUpdating = True

End Sub


Call Sub UnMergeFill()

Dim cell As Range, joinedCells As Range

For Each cell In ThisWorkbook.ActiveSheet.UsedRange
    If cell.MergeCells Then
        Set joinedCells = cell.MergeArea
        cell.MergeCells = False
        joinedCells.Value = cell.Value
    End If
Next

End Sub

'''

Answer 1

Попробуйте:

Sub AllWorkbooks()

   Dim MyFolder As String
   Dim MyFile As String
   Dim wbk As Workbook

On Error Resume Next

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Please select a folder"

.Show

.AllowMultiSelect = False

   If .SelectedItems.Count = 0 Then

MsgBox "You did not select a folder"

      Exit Sub

   End If

MyFolder = .SelectedItems(1) & "\"

End With

MyFile = Dir(MyFolder)

Do While MyFile <> “”

   Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)


Call UnMergeFill(wbk)


wbk.Close savechanges:=True

MyFile = Dir

Loop

Application.ScreenUpdating = True

End Sub


Sub UnMergeFill(wb As Workbook)

Dim cell As Range, joinedCells As Range

For Each cell In wb.ActiveSheet.UsedRange
    If cell.mergeCells Then
        Set joinedCells = cell.MergeArea
        cell.mergeCells = False
        joinedCells.Value = cell.Value
    End If
Next

End Sub