تصحيح الخطأ في كود تجميع الشيتات في شيت واحد

[2saad]

اعضاء المنتدي الكرام بعد سلام الله عليكم ورحمة الله وبركاته

الملف المرفق 

محتاج اجمع الشيتات ( كي جي1 و1 و2 ) في في شيت (مجمع الصفوف) والكود موجود ولكن فيه خطأ ومحتاج لتصحيح الخطأ

ولكم جزيل الشكر ووافر الاحتراممجمع الصفوف.xlsm

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

أخطاء بسيطة جدا تدل على محاولة تطبيق الكود بدون فهم متغيراته وكائناته

إن شاء الله يكون هذا هو المطلوب

Sub ColllectShets()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, x As Long
Dim Arr, i As Long
Set ws = Sheets("مجمع الصفوف")
Application.ScreenUpdating = False
ws.Range("C10:p10000").Clear
For Each Sh In Sheets(Array("1", "2", "كي جي1"))
x = WorksheetFunction.CountA(Sh.Range("a10:a" & Sh.Range("a" & Rows.Count).End(xlUp).Row))
Sh.Range("C10:p" & Sh.Range("a" & Rows.Count).End(xlUp).Row).Copy
If LR < 9 Then
LR = 9
Else
LR = ws.Range("D" & Rows.Count).End(xlUp).Row
End If
ws.Range("C" & LR + 1).PasteSpecial xlPasteFormats
ws.Range("C" & LR + 1).PasteSpecial xlPasteValues
ws.Range("p" & LR + 1).Resize(x).Value = Sh.Name
Application.CutCopyMode = False
For i = 10 To ws.Range("d" & Rows.Count).End(xlUp).Row
ws.Range("C" & i) = i - 9
Next i
Next Sh
Application.ScreenUpdating = True
End Sub

لاحظ استعمالك للعمود C للحصول على آخر صف بالرغم من فراغ العمود C

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

بالتوفيق

[2saad]

شكرا جزيلا استاذنا الفاضل

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

الحمد لله الذي بنعمته تتم الصالحات