الترحيل من مصنف لمصنف آخر في مسار على البارتشن D

[صلاح الدين أبو حسين]

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

اولا اتقدم بالشكر الجزيل لجميع اعضاء المنتدى الرائع الذي ينتفع منه الجميع ، الحقيقة يا اخوتي الاكارم بالنسبة لي فقد انتفعت من المنتدى الجميل في مواضيع كثيرة من الاكسل 

ثانيا : ارجو من السادة الافاضل مساعدتي على حل هذه المشكلة في الملفين المرفقين ، فانا اريد ترحيل البيانات من الملف الاول المسمى "تفاصيل" الى الملف الثاني الذي اسمه "Z" فمنذ عملي لهذا الكود عمل بشكل جيد لفترة 10 ايام والان لا يعمل ويكتب لي عبارة

 " run-time error '9' :

subscript out of range"

يرجى المساعدة ولكم مني جزيل الشكر

 

ترحيل الى ملف خارجي.rar

[صلاح الدين أبو حسين]

       

[ياسر خليل أبو البراء]

أخي الفاضل صلاح الدين أبو حسين

أهلا ومرحبا بك في المنتدى ... نزلت أهلاً وحللت سهلاً ونورت بين إخوانك .. إن شاء الله تستفيد من إخوانك بالمنتدى

 

أولاً : خلاص كفاية ترحيب وندخل في المفيد

ثانيا : الكود بتاعك مش عاجبني (أيوا مش عاجبني !! عندك مااااااانع .. اعترض لو تقدر)

ثالثاً : الأخطاء في الكود ببساطة كالتالي

 1 - الخطأ الأول في السطر

Workbooks.Open Filename:="d:\z.xls"

هذا هو الشكل الصحيح حيث أنك نسيت علامة \ في مسار الملف .. ويجب ألا تنسى أن يكون الملف في نفس المسار المذكور أي أن المصنف المسمى z.xls يجب أن يكون على البارتشن C

 

2- حضرتك في الكود في الجزء اللي بعد علامة يساوي كاتب اسم المصنف "برنامج العمل" ودا مش حااااصل لأن المصنف اسمه "تفاصيل" وورقة العمل المطلوب العمل عليها اسمها بردو "تفاصيل"

فالشكل الصحيح للكود يجب أن يكون كالتاااااااالي :

Sub ss()
    Sheets("تفاصيل").Select
    MM = Range("Q1").Value
    
    Workbooks.Open Filename:="d:\z.xls"
    Workbooks("z").Sheets("total").Range("a2:p1000").ClearContents
    lastr = Workbooks("z").Sheets("total").Range("A1").CurrentRegion.Rows.Count
    
    For pp = 1 To (MM)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 1) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 1)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 5) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 5)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 4) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 4)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 6) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 6)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 3) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 3)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 2) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 2)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 7) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 7)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 8) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 8)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 9) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 9)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 10) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 10)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 11) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 11)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 12) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 12)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 13) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 13)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 14) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 14)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 15) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 15)
        Workbooks("z").Sheets("total").Cells(lastr + pp, 16) = Workbooks("تفاصيل").Sheets("تفاصيل").Cells(pp + 1, 16)
        'Workbooks("work").Sheets("total").Cells(lastr + pp, 1) = lastr + pp
    Next
    
    Workbooks("z").Save
    Workbooks("z").Close
End Sub

شوية أورجع لك بكود يؤدي نفس الغرض بأقل مجهود وبدون كل اللف الموجود

[ياسر خليل أبو البراء]

الأخ الكريم صلاح الدين

جرب الكود التالي وشوف هل يؤدي الغرض أم لا

Sub ss()
    Dim LR As Long
    Application.ScreenUpdating = False
        Workbooks.Open Filename:="D:\z.xls"
        With Workbooks("z")
            .Sheets("total").Range("A2:P1000").ClearContents
                With Workbooks("تفاصيل").Sheets("تفاصيل")
                    .Activate
                    .Range("A2:P" & .Cells(Rows.Count, 2).End(xlUp).Row).Copy
                End With
            LR = .Sheets("total").Range("A1").CurrentRegion.Rows.Count + 1
            .Sheets("total").Range("A" & LR).PasteSpecial xlPasteValues
            .Save
            .Close
        End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

[صلاح الدين أبو حسين]

اخي الفاضل ياسر خليل المحترم

بارك الله بكم وزاد علمكم وانار دربكم . 

معاذ الله اني اعترض على اقتراحك او تعديلك !!! فانا مجرد تلميذ بالنسبة لكم   

بالنسبة للكود المرفق بالبرنامج  ... قد اكون غيرته بشكل غير مقصود قبل ارساله لكم فهو كان يعمل سابقاً

وبالنسبة لي فانا لا اقوم بكتابة الاكواد يدويا ... اي انني اقوم بنسخ الكود الذي يؤدي الغرض واعمل بعض التعديلات عليه بما يناسبني .

اما بالنسبة للكود ( المختصر ) الذي ارسلته لي في المشاركة فانه يعمل بكفاءة ... سلَّم الله يديك .   

[ياسر خليل أبو البراء]

الأخ الكريم صلاح الدين

جزيت خيراً على كلماتك الرقيقة ودعائك الطيب

 

وبعدين من حقك تعترض (إنت مواطن ومن حق كل مواطن إنه يعترض .. اللي عايز يعترض يتفضل .. وإحنا هنعمل اللي إحنا عايزينه بردو .. سياسة مصرية)

الدستور يكفل لك حق الاعتراض

 

بلاش كلام في السياسة عشان دا مخالف للقواعد .. مبقاش مشرف وأخالف (متجيش مني)

 

بالمناسبة هل اطلعت على التوجيهات

http://www.officena.net/ib/index.php?showtopic=60147

عشان شكلك نسيت تحدد أفضل إجابة

 

تقبل تحياتي