ترحيل بدون فراغات

[وائل الاسيوطي]

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

اخواني الكرام الكود لاخي واستاذي العيدروس والكود يعمل بكفائه ولكني اود اضافه ترحيل الخلايا الملونه بالاصفر في الترحيل

حيث انها لايتم ترحيلها في الجدول الاول والثاني ولكن يتم ترحيلها في باقي الجداول

وكنت اود ايضا ان يتم الترحيل بدون اسطر فارغه 

new year file.rar

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

أخي الكريم وائل

ممكن ترفق شكل النتائج المتوقعة .. وهل الترحيل يتم مرة واحدة أم أنه متكرر ؟

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

وما هي الخلايا التي يتم ترحيلها ؟ والإجمالي لكل جدول على حدا أم لكل الجداول ؟

أسئلة كثيرة لا حصر لها .. اعذرني لأنني لم أتابع ملفك من قبل .. فهو بالنسبة لي طلاسم

وضح وفسر وفصل .. والأفضل ترفق شكل النتائج المتوقعة ليسهل الوصول لحل

 

 

[وائل الاسيوطي]

شاكر مرورك اخي ابو البراء 

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

المجموع لكل جدول علي حده كما المثال  وطلب اخير ان يرحل الجداول التي تحتوي علي اسم الموظف بها فقط بمعني الصفحه تقريبا 10 جداول الكود يرحل الجداول التي تحتوي فقط علي اسم الموظف ممكن تكون سته اوسبعه جداول

new year file.rar

[وائل الاسيوطي]

للرفع رفع الله قدركم

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

أخي الكريم وائل

كليك يمين على اسم ورقة العمل ثم الأمر View code ثم ضع الكود التالي

Sub Transfer_Tables_Data()
    Dim CN, D As Integer, R As Integer, N As Integer
    Const C = 30, S = "*Area"
    Dim Rc As Range, Rg As Range
    CN = [{1,3,7,28,29,30}]
    D = 2
    
    Application.ScreenUpdating = False
        If Me.UsedRange.Rows.Count > 1 Then Intersect(Me.UsedRange.Offset(1), Me.UsedRange).ClearContents
        Set Rg = Worksheets(1).UsedRange.Columns("B:C")
        Set Rc = Rg.Find(S, , xlValues, xlWhole)
        
        If Not Rc Is Nothing Then
            R = Rc.Row
            Do
                If Rc(0, 3).Value > "" Then
                    With Rc.CurrentRegion.Columns(2).Rows
                        N = .Find("*", , , , , xlPrevious).Row - Rc.Row - 2
                        Cells(D, 2).Resize(N + 1, 3).Value = Array(Rc(0, 12).Value, Rc(1, 3).Value, Rc(0, 3).Value)
                        Cells(D, 5).Resize(N, 6).Value = Application.Index(Rc(4, 2).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN)
                        Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Item(.Count).Resize(2, C).Value, 1, CN)
                        D = D + N + 1
                    End With
                End If
                Set Rc = Rg.Find(S, Rc)
            Loop While Rc.Row > R
            
            Set Rc = Nothing
        End If
        Set Rg = Nothing
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

[وائل الاسيوطي]

46 دقائق مضت, ياسر خليل أبو البراء said:

أ

تمام  جزاك الله خيرا اخي الكريم ابو البراء بس كدا انا هاشتغل بالكودين

تم تعديل ديسمبر 26, 2015 بواسطه وائل الاسيوطي

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

أخي الكريم وائل

مش فاهم يعني ايه هتشتغل بالكودين ...

ألم يؤدي الكود المرفق في المشاركة السابقة الغرض ؟أم أن هناك إضافات أخرى مطلوبة على الكود

[وائل الاسيوطي]

55 دقائق مضت, ياسر خليل أبو البراء said:

 

 

اخي الكريم ابو البراء الكود يعمل بكفائه 100 فل و16 بس علي صفحه واحده بمعني الملف الاصلي به 17 صفحه كل واحده خاصه بشهر ومن المفترض ترحيل كل الشهور تحت بعض في صفحه البيانات الكود تمام في اول صفحه لكن في الثانيه كان بيمسح بياناتها

خالص تقديري وعرفاني

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

الأصل أخي وائل أن يتم إرفاق ملف معبر عن الملف الأصلي ..

بالنسبة للكود يوضع في حدث ورقة العمل كما ذكرت لك .. هل وضعت الكود في موديول عادي أم في حدث الورقة كما ذكرت لك؟

[وائل الاسيوطي]

لا وضعته في حدث الورقه ولكنك لم تحدد اي ورقه ( ابقي حدد بعد كدا انت عارف نظري ضعيف )

لكني الان صححته وتمام لكن يبقي تكرار الصفحات 

خالص احترامي ومعذره علي سوء الفهم

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

أخي الكريم وائل

حصل خير ..الغلطة دي عندي ..كان لازم أحدد ورقة العمل 

أما موضوع تكرار الصفحات فصراحة لا أفهم مقصودك ... حاول ترفق ملف آخر وتوضح المطلوب فيه .. حتى تتضح الصورة

[وائل الاسيوطي]

هكذا اخي ابو البراء نفس الشروط ونفس البيانات المرحله لكن باختلاف اسم الصفحه والشهر

new year file.rar

تم تعديل ديسمبر 26, 2015 بواسطه وائل الاسيوطي

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

صراحة لم أفهم المنطق

حاول توضح بأسلوب بسيط ما هي شكل المخرجات ؟؟؟

التعامل مع الملف المرفق في مشاركتك الأولى كان على أساس ورقة عمل واحدة

المطلوب الآن ترحيل من جميع أوراق العمل الموجودة إلى ورقة العمل Data أم ماذا ؟؟ التبس الأمر على العبد لله فالمعذرة

 

[وائل الاسيوطي]

كل ورقه عمل تمثل بيانات شهر مفصله قمثلا نحن في شهر واحد يقوم الكود بترحيل بيانات الشهر الحالي فقط

والشهر القادم نرحل بيانات شهر اتنين فقط ليصبح في صفحه البيانات بيانات شهر واحد واسفلها بيانات شهر اتنين

وهكذا لباقي الشهور كل شهر يرحل لوحده مضافا الي ماسبق ترحيله من قبل

خالص احترامي ومعذره علي الاطاله

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

أخي الكريم وائل

إليك الكود ويوضع في موديول عادي (بلاش حدث ورقة العمل)

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

أرجو أن يكون المطلوب

 

Sub TransferTables_YasserKhalil()
    Dim CN, D As Integer, R As Integer, L As Integer, N As Integer, strMonth As String
    Const C = 30
    CN = [{1,3,7,28,29,30}]
    D = Cells(Rows.Count, 2).End(3).Row + 1
    R = 5
    strMonth = Month(Date)
    
    If Evaluate("=ISREF('" & strMonth & "'!A1)") Then
        Application.ScreenUpdating = False
            With ThisWorkbook.Worksheets(strMonth)
                L = .Cells(.Rows.Count, 3).End(xlUp).Row
                
                Do
                    With .Cells(R, 4)
                        If .Value > "" Then
                            N = .CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - R - 3
                            Cells(D, 2).Resize(N + 1, 3).Value = Array(.Cells(1, 10).Value, .Cells(2).Value, .Value)
                            Cells(D, 5).Resize(N, 6).Value = Application.Index(.Cells(5, 0).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN)
                            Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Cells(17, 0).Resize(2, C).Value, 1, CN)
                            D = D + N + 1
                        End If
                    End With
                    
                    R = R + 21
                Loop While R < L
            End With
        Application.ScreenUpdating = True
    Else
        MsgBox "There Is No Such Sheet", 64: Exit Sub
    End If
End Sub

تقبل تحياتي

[وائل الاسيوطي]

طيب اخي ياسر كدا انا في صفحات زي q1 ,q2 مش هاتترحل 

انت ممكن مشكورا وليس مأمورا نخلي الترحيل  من الصفحه النشطه وتبقي كدا الامور تمام

خالص تقديري

 

 

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

أخي وائل

كدا أنا هتوه منك

مرة تقولي حسب الشهر .. ودلوقتي تقولي فيه أوراق تانية باسم q1 و q2 .. وفي النهاية غيرت مسارك وقلت خلينا نتعامل مع الورقة النشطة

يا ريت تكون دي آخر محاولة مني

Sub TransferTables_YasserKhalil()
    Dim CN, D As Integer, R As Integer, L As Integer, N As Integer
    Const C = 30
    CN = [{1,3,7,28,29,30}]
    D = Sheets("Data").Cells(Rows.Count, 2).End(3).Row + 1
    R = 5
    
    Application.ScreenUpdating = False
        With ActiveSheet
            L = .Cells(.Rows.Count, 3).End(xlUp).Row
            
            Do
                With .Cells(R, 4)
                    If .Value > "" Then
                        N = .CurrentRegion.Columns(2).Find("*", , xlValues, , , xlPrevious).Row - R - 3
                        Sheets("Data").Cells(D, 2).Resize(N + 1, 3).Value = Array(.Cells(1, 10).Value, .Cells(2).Value, .Value)
                        Sheets("Data").Cells(D, 5).Resize(N, 6).Value = Application.Index(.Cells(5, 0).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN)
                        Sheets("Data").Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Cells(17, 0).Resize(2, C).Value, 1, CN)
                        D = D + N + 1
                    End If
                End With
                
                R = R + 21
            Loop While R < L
        End With
    Application.ScreenUpdating = True
End Sub

ويا رب تظبط معاك عشان أنا بدأت أهيس وشوية ورايح أنااااااااااااااااااااااااااااااااااااااااام

تقبل تحياتي

[وائل الاسيوطي]

تسلم ايدك يابركات يابو الحركات 

لا ياباشا تمام التمام 

وتصبح علي خير وسعاده وهنا

4 دقائق مضت, ياسر خليل أبو البراء said:

 

 

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

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

وتصبح على خير يا أخ وائل

تقبل وافر تقديري واحترامي