عمل كود ترحيل يعمل مع كل الصفحات

[gamalin]

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

 

all.rar

[ibn_egypt]

اخى الفاضل

 

ارفق الملف، فما ارفقته ما هو الا موديول وفقط 

 

تحياتى  

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

أخي الفاضل أرسل الملف نفسه وليس الكود فقط

[gamalin]

ارفقت الملف

اريد ترحيل البيانات في كل الصفحات الى صفحة شيت 1

تجميع.rar

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

دايما سابقني يا ابن مصر ..مقطع عليا كدا دايما..

فين كود النهاردة (هصدعك!!)

[gamalin]

هل من مجيب عطلان على الكود ده يا شباب اكرمكم الله

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

أخي الفاضل جرب الملف التالي

 

Post All Sheets.rar

[gamalin]

اكرمك الله وزادك علما

ممكن لو تفضلت علي تشرح لي اليه عمل الكود لو امكن

[gamalin]

كود اكثر من رائع وبسيط اشكرك ممكن لو تفضلت تقول لي

كان ايه الخطأ في كود الهواة اللي كنت كاتبه

[gamalin]

اخي الكريم

في الخلية  b2 من كل شيت اسم المورد

هي يمكن تكراره بجوار الاسطر الخاصة به  لمعرفة كل بيان يخص اي مورد

جزاك الله خيرا

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

أخي الفاضل أعتذر إليك الوقت تأخر ولابد أن أنام الآن لأني عندي امتحانات بدري وشغل طول النهار

إن شاء الله تجد من يساعدك في إتمام المطلوب

أستودعك الله

[gamalin]

اشكرك على كل حال جزاك الله كل خير

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

جرب التعديل

Sub Post()
    Dim LRMain As Long
    Dim LRWS As Long
    Dim WS As Worksheet
    
    Set WS = ActiveSheet
    Application.ScreenUpdating = False
        Range("B3:P10000").ClearContents
        
        For Each WS In ThisWorkbook.Worksheets
            If WS.Name <> Sheets("Sheet1").Name Then
                WS.Activate
                LRWS = WS.Range("B" & Rows.Count).End(xlUp).Row
                If IsEmpty(WS.Range("B5")) Then GoTo 1
                Range("B5:P" & LRWS).Copy
                Sheets("Sheet1").Activate
                LRMain = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 1
                Sheets("Sheet1").Range("B" & LRMain).PasteSpecial xlPasteValues
                
                Application.CutCopyMode = False
            End If
                Selection.Offset(0, 15).Resize(1, 1).Value = WS.Range("B2").Value
1         Next WS
    Call AutoNumberEvaluate
    Sheets("Sheet1").Range("A1").Select
    Application.ScreenUpdating = True

End Sub

Sub AutoNumberEvaluate()
    Application.ScreenUpdating = False
    Dim LRC As Long
    LRC = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
        With Range("A3:A" & LRC)
            .ClearContents
            .Value = Evaluate("ROW(A1:A" & .Rows.Count & ")")
        End With
    Application.ScreenUpdating = True
End Sub