Макрос переименования файла завершается, пока L oop Немедленно

Question

Ниже приведен код, который должен go в папку, а затем сохранять каждый файл в новую папку как имя автора и счетчик.

При переименовании файл сохраняется как я, а не оригинальный автор? Есть какие-нибудь советы о том, как сохранить его как первоначального автора, а не последнего автора?

Дайте мне знать, если мне нужно объяснить больше.

 Sub RenameExcelFilesbyAuthor()


Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Counter As Integer

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = "C:\Users\Logan\Documents\Excel Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
 myPath = myPath
 If myPath = "" Then GoTo ResetSettings

 'Target File Extension (must include wildcard "*")
 myExtension = "*.xlsx*"

 'Target Path with Ending Extention
 myFile = Dir(myPath & myExtension)

 Counter = 1

 'Loop through each Excel file in folder
 Do While myFile <> ""
  'ReadOnly = False
    Set wb = Nothing
    On Error Resume Next
    'Set variable equal to opened workbook
     Set wb = Workbooks.Open(Filename:=myPath & myFile)
    On Error GoTo 0
    If wb Is Nothing Then
        wb.Close
    Else
    Counter = Counter + 1
    'Ensure Workbook has opened before moving on to next line of code
     DoEvents

   'Change First Worksheet's Background Fill Blue
     wb.SaveAs Filename:="C:\Users\Name\Documents\New Folder" & ThisWorkbook.BuiltinDocumentProperties("Author") & Counter

   'Save and Close Workbook
     wb.Close SaveChanges:=True

   'Ensure Workbook has closed before moving on to next line of code
     DoEvents
    End If

   'Get next file name
     myFile = Dir

 Loop

 'Message Box when tasks are completed
 MsgBox "Task Complete!"

ResetSettings:
 'Reset Macro Optimization Settings
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True

End Sub

Answer 1

ThisWorkbook против ActiveWorkbook

• Вы должны использовать wb, ActiveWorkbook вместо ThisWorkbook.
• ThisWorkbook относится к книге, содержащей этот код.
• Вам не хватает backslash (\) после New Folder.

Измененная строка

wb.SaveAs Filename:="C:\Users\Name\Documents\New Folder\" _
  & wb.BuiltinDocumentProperties("Author") & " " & Counter & ".xlsx"

Используйте myExtension = "*.xlsx" (вместо "*.xlsx*"), потому что вы хотите, чтобы файлы заканчивались расширением, чтобы после него не было никаких символов.