Я работал над этим кодом, склеивая элементы.Он берет рабочие листы из рабочей книги, сохраняет их как отдельные рабочие книги в новой папке, а затем отправляет их по электронной почте руководителям для их действий.Я написал это вслепую, не зная, как структурирована рабочая тетрадь.Затем я обнаружил, что у рабочей книги (это файл с ограниченным доступом) есть первые 4 рабочих листа, которые мне нужно игнорировать.Я добавил еще один цикл if, чтобы игнорировать таблицы, содержащие строку «IGNORE» в ячейке A2.Это работало так быстро, прежде чем я добавил это, если утверждение сейчас, кажется, это занимает гораздо больше времени.Боюсь, что это будет неоправданно медленно на рабочей книге, на которой я собираюсь ее реализовать (20 рабочих листов).Я собираюсь посмотреть, как он работает в режиме отладки, я думаю, но любая помощь будет принята с благодарностью.Вот код:
Sub SplitWorkbook()
'TMP June 5, 2018 Export and save worksheets as new Workbook in a new folder
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
'TMP June 5, 2018 added following dims for auto email generator submodule
Dim oApp As Object
Dim oMail As Object
Dim eAdd As Object
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
Set eAdd = ActiveSheet.Range("A2")
If eAdd <> "IGNORE" Then
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
'TMP June 5,2018 Added submodule to create and show the Outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
Set eAdd = ActiveSheet.Range("A1")
With oMail
'selects the to from A1
.to = ActiveSheet.Range("A1")
'Sets the subject
.Subject = "Your hammer sheet is attached"
'Creates the body of the email
.body = ActiveSheet.Range("A2") & vbNewLine & vbNewLine & _
"Here is your hammer sheet to fill out and send back within 2 days" & vbNewLine & vbNewLine & "Thanks a lot," & vbNewLine & vbNewLine & "Mounir Samara"
.Attachments.Add xFile
.Display
End With
Application.ActiveWorkbook.Close False
End If ''IGNORE' if loop
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub