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

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

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

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

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

رجاء اذا كان المثال غير واضح ابلاغي لتوضيح الامر اكثر من ذلك

وشاكر لكم مقدما 

REAL Q4 new SALES file2222.rar

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

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

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

اخواني هل الموضوع صعب ام هو يحتاج توضيح اكثر

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

تم تغيير الملف تسهيلا علي الاخوه 

المطلوب ترحيل البيانات من الاعمده الملونه بالاصفر الي الصفحه الاخري

فقط اذا كان الخليه في العمود c يختوي علي بيانات يرحل بيانات الصف 

REAL Q4 new SALES file2222.rar

[الـعيدروس]

السلام عليكم

حسب فهمي للمطلوب

جرب الكود التالي

Sub Ali()
Dim Sw As Worksheet, Sh As Worksheet
Dim Lr As Long, Rw As Long
Dim R As Range
Set Sw = Sheets("1"): Set Sh = Sheets("data")
With Sw
    Lr = Split(Sh.UsedRange.Address, "$")(4)
    Sh.Cells(Lr, 2) = .[M5]
    Sh.Cells(Lr, 3) = .[D6]
    Sh.Cells(Lr, 4) = .[D5]
    Set R = [C9].End(xlDown)
    Rw = Split(R.Address, "$")(2)
    Union(.Range(.[C9], "C" & Rw), .Range(.[E9], "E" & Rw), .Range(.[I9], "I" & Rw) _
     , .Range(.[AD9], "AD" & Rw), .Range(.[AE9], "AE" & Rw), .Range(.[AF9], "AF" & Rw)).Copy
    Sh.Cells(Lr, 5).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End With
Set Sw = Nothing: Set Sh = Nothing: Set R = Nothing
End Sub

 

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

منذ ساعه, الـعيدروس said:

 

 

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

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

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

REAL Q4 new SALES file2222.rar

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

[الـعيدروس]

هل عدد صفوف الجدول ثابته ؟

 وهل الصفوف الفارغه بين كل جدول ثابته ؟

    وكم الحد الاعلى للجداول 

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

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

[الـعيدروس]

جرب هذا التعديل

Sub Ali_C()
Dim Sw As Worksheet, Sh As Worksheet
Dim Lr, LrR, Rw As Long
Dim Rn As Range, Rng As Range, R As Range
Set Sw = Sheets("1"): Set Sh = Sheets("data")
Lr = Sw.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
'-----------
 Ali_Ap False
'-----------
With Sw
  For Rw = 5 To Lr Step 21
      I = I + 1
     ''-----------------------------------------------------------------------------------------
      Set Rn = .Cells(Rw + 4, "C").End(xlDown): Rr = Split(Rn.Address, "$")(2)
      LrR = Sh.Cells(Sh.Rows.Count, 5).End(xlUp).Offset(IIf(I = 1, 1, 2)).Row
     .Range("M" & Rw).Copy: Sh.Range("B" & LrR).PasteSpecial xlPasteValues
      .Range("B" & Rw + 1).Copy: Sh.Range("C" & LrR).PasteSpecial xlPasteValues
     .Range("D" & Rw).Copy: Sh.Range("D" & LrR).PasteSpecial xlPasteValues
     .Range(.Cells(Rw + 4, "C"), "C" & Rr).Copy: Sh.Range("E" & LrR).PasteSpecial xlPasteValues
    ''-----------------------------------------------------------------------------------------
     .Range(.Cells(Rw + 4, "E"), "E" & Rr).Copy: Sh.Range("F" & LrR).PasteSpecial xlPasteValues
      .Range(.Cells(Rw + 4, "I"), "I" & Rr).Copy: Sh.Range("G" & LrR).PasteSpecial xlPasteValues
    .Range(.Cells(Rw + 4, "AD"), "AD" & Rr).Copy: Sh.Range("H" & LrR).PasteSpecial xlPasteValues
     .Range(.Cells(Rw + 4, "AE"), "AE" & Rr).Copy: Sh.Range("I" & LrR).PasteSpecial xlPasteValues
    .Range(.Cells(Rw + 4, "AF"), "AF" & Rr).Copy: Sh.Range("J" & LrR).PasteSpecial xlPasteValues
    ''-----------------------------------------------------------------------------------------
Next
End With
'-----------
 Ali_Ap True
'-----------
Application.CutCopyMode = False
Set Sw = Nothing: Set Sh = Nothing: Set Rn = Nothing
End Sub
Public Function Ali_Ap(Bn As Boolean)
    With Application
         .Calculation = IIf(Bn, -4105, -4135)
         .ScreenUpdating = Bn
    End With
End Function

 

تم تعديل ديسمبر 19, 2015 بواسطه الـعيدروس

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

جزاك الله كل خير استاذي العيدروس الكود يعمل بكفاءه وبكل سلاسه

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

وعذرا علي الاطاله وكثره الطلبات 

 

28 دقائق مضت, الـعيدروس said:

 

 

[الـعيدروس]

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

 اي مسميات الاوراق وماهي شروط الترحيل وضحها في المرفق

 

اقتباس

بها بيانات الشهرين معا

شهرين وقلت 

اقتباس

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

وعدد 15 صفحه الشهرين تقصد لكل شهر ورقه وفي كل شهر 15 جدول ؟

 

 

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

14 ساعات مضت, الـعيدروس said:

 

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

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

ولكن هناك مشكله اخري ظهرت هي الاسطر الفارغه الكود يظهر يرحل البيانات هكذا

 

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

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

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

new year file.zip

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

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

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

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

 

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

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

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

اخي العيدروس ينشغل عن الرد فلا يكمل احد من الاخوه ما بدأه