ايجاد الخطأ في كود خاص بترحيل البيانات

[ibra9]

السادة / أعضاء المنتدى المحترمين

السلام عليكم ورحمة الله

(منقول) (Compile Error Next without for) اتمنى أجد المساعدة في تصحيح الخلل في كود الملف المرفق حيث تظهر رسالة 

Option Explicit
Sub test()
Dim ws As Worksheet
Dim lr As Integer
Application.ScreenUpdating = False
Sheets("البيان المجمع").Range("a4:e10000").ClearContents
 For Each ws In ThisWorkbook.Worksheets
  If ws.Name <> "البيان المجمع" Then
    If ws.Name <> "ملاحظات" Then
    With ws
     .Activate
      lr = .Cells(Rows.Count, 1).End(xlUp).Row
       .Range("a4:e" & lr).Copy
    With Sheets("البيان المجمع")
     .Range("a" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteValues
          End With
       End With
        End If
         Next
          Sheets("البيان المجمع").Activate: Range("a1").Select
  Application.CutCopyMode = False
   Application.ScreenUpdating = True
    End If
End Sub

وشاكرا مقدما 

تم ارفاق الملف112.xlsm

[أ / محمد صالح]

يمكنك استعمال هذا الكود

وهو نفس الكود ولكن بتعديلات بسيطة

Sub test()
Dim ws As Worksheet, lr As Integer, lr2 As Integer
Application.ScreenUpdating = False
Sheets("البيان المجمع").Range("a4:e10000").ClearContents
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "البيان المجمع" And ws.Name <> "ملاحظات" Then
        With ws
            .Activate
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            lr2 = Sheets("البيان المجمع").Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets("البيان المجمع").Range("a" & lr2 & ":e" & lr2 + lr - 4).Value = .Range("a4:e" & lr).Value
        End With
    End If
Next
Sheets("البيان المجمع").Activate: Range("a1").Select
Application.ScreenUpdating = True
End Sub

بالتوفيق 

[ibra9]

شكرا من القلب للأستاذ/ محمد صالح

[أ / محمد صالح]

الشكر لله الذي وفقنا لهذا