الخروج من الماكرو مبكرًا دون أي خطأ
سؤال
أنا أستخدم الكود أدناه لنسخ جميع المصنفات من مجلد معين إلى مصنف واحد.9 من أصل 10 مرات يعمل الكود بشكل جيد ويتم نسخ جميع البيانات ولكن في بعض الأحيان يبدو أن الماكرو يخرج مبكرًا دون الانتهاء حيث لا يتم عرض msgbox أبدًا ولا أتلقى أي رسالة خطأ.يبدو أنه تم الخروج من الماكرو لأنه يسمح لي بتشغيل وحدات ماكرو أخرى.هل يمكن لأحد أن ينصحني ما الذي قد يسبب هذا؟يبدو أن هذا يحدث إذا بدأت في القيام بأشياء أخرى على جهاز الكمبيوتر الخاص بك أثناء تشغيل الماكرو.
Sub GetSheets()
Application.ScreenUpdating = False
Dim response
response = MsgBox("This will take some time to run. Are you sure you want to proceed?", vbYesNo)
If response = vbNo Then
Exit Sub
End If
Application.Run ("GetxlsxFiles")
Application.Run ("GetxlsFiles")
DataCopied = 1
Sheets("Instructions").Select
MsgBox "Completed Successfully"
End Sub
Sub GetxlsxFiles()
Dim Sheet As Worksheet
Path = Sheets("Instructions").Range("FileName").Value
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True, Password:="Password"
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=Workbooks("RSModel.xlsm").Sheets("Current KPIs")
Next Sheet
Workbooks(Filename).Close saveChanges:=False
Filename = Dir()
Loop
End Sub
إن getxlsfiles sub هو نفسه تمامًا كما هو مذكور أعلاه باستثناء امتداد الملف.
المحلول
لقد قمت بإعادة كتابة الكود الخاص بك وقمت فقط بتقديم التعليقات هناك.
هناك الكثير مما لا يمكن احتواؤه في التعليق.
هنا GetxlsxFiles Sub
:
إنه في الواقع مختصر إذا قمت بإزالة التعليقات وهو ما يفسر ما فعلته.
Sub GetxlsxFiles()
Dim wb As Workbook, wbTemp As Workbook
Dim Path As String, Filename As String ', masterWB As String
Dim Sheet As Worksheet
'~~> Assuming the path is correct
Path = Sheets("Instructions").Range("FileName").Value
'~~> Path should contain e.g. "C:\TestFolder\"
Filename = Dir(Path & "*.xlsx")
'~~> Assuming you are consolidating all sheets
'~~> in the workbook that contain the macro
Set wb = ThisWorkbook
'~~> If not, use the commented line below
'~~> Take note that you do not include the file extension
'Set wb = Workbooks("RSModel")
'~~> Or you can also open it like this
'masterWB = "C:\Foldername\RSModel.xlsm"
'Set wb = Workbooks.Open(Filename:=masterWB, ReadOnly:=True)
Do While Filename <> ""
Set wbTemp = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True, _
Password:="Password")
For Each Sheet In wbTemp.Sheets
'~~> this adds the sheet after the last sheet in the target WB
'~~> If you specifically want to add it after a specific sheet,
'~~> use the commented line
Sheet.Copy After:=wb.Sheets(wb.Sheets.Count)
'Sheet.Copy After:=wb.Sheets("Current KPIs")
Next
wbTemp.Close False
Filename = Dir
Loop
End Sub
هنا هو GetSheets Sub
:
Sub GetSheets()
Application.ScreenUpdating = False
Dim response As Integer
response = MsgBox("This will take some time to run." & vbNewLine & _
"Are you sure you want to proceed?", vbYesNo)
'~~> execute IF in one line
If response = vbNo Then Exit Sub
'~~> No need to use Application.Run. Call the subs directly
GetxlsxFiles
GetxlsFiles
'~~> Not sure what's this for so I commented it
'DataCopied = 1
'~~> If you want below sheet to be selected then
ThisWorkbook.Sheets("Instructions").Select
MsgBox "Completed Successfully", vbInformation
End Sub
أعتقد أن ما ورد أعلاه يجب أن يكون قريبًا مما تريد.
أتمنى أن يساعدك هذا.