اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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

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

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

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:

أ

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

تم تعديل بواسطه وائل الاسيوطي
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

 

 

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

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

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

new year file.rar

تم تعديل بواسطه وائل الاسيوطي
رابط هذا التعليق
شارك

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

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

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

المطلوب الآن ترحيل من جميع أوراق العمل الموجودة إلى ورقة العمل 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

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

تقبل تحياتي

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information