ترحيل شيتات ملف الى ملف احر بصفحة واحدة

[ابو عمران]

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

المرجو من اساتدتنا بهدا المنتدى الرائع مساعدتي في :

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

 

Bureau.rar

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

وعليكم السلام أخي الكريم أبو عمران

أهلاً بك في المنتدى ونورت بين إخوانك

إن شاء الله أعمل على موضوعك غداً إذا لم يتدخل أحد الأخوة الكرام

تقبل تحياتي

[ابو عمران]

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

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

أعتذر إليك أخي الكريم أبو عمران

ربما لا أستطيع تلبية طلبك في الوقت الحالي لأنني أعاني من بعض الإرهاق والمرض .. وإن شاء الله أحاول تلبية طلبك قريباً .. ولكن لا تنسى أن تضع رد كل فترة وجيزة لكي لا أنسى

تقبل تحياتي

[ابو عمران]

اللهم رب الناس اذهب الباس اشف انت الشافي لا شفاء إلا شفاؤك شفاءا لا يغادر سقما 

اللهم اشف اخي ياسر و بارك له في عمره وقه كل شر 

[عبدالرحمن حارثة]

لا بأس عليك استاذ ياسر - نساله تعالى لك العفو والعافية في الدنيا والاخرة

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

جزاكم الله خيراً إخواني وأحبابي في الله .. وبارك الله فيكم

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

السلام عليكم

جرب الكود التالي عله يفي بالغرض .. وأعتذر أني وعدتك فنسيت ولكن يجب متابعة الموضوع بالردود لكي يظهر الموضوع في أول صفحة بالمنتدى وأستطيع رؤيته .. عموماً حصل خير

Sub CollectFromMultipleSheets()
    Dim wb          As Workbook
    Dim wsTarget    As Worksheet
    Dim wsSource    As Worksheet
    Dim arr         As Variant
    Dim i           As Variant
    Dim cr          As Variant
    Dim j           As Long
    Dim lr          As Long
    Dim x           As Long

    Application.ScreenUpdating = False
        Set wsTarget = ThisWorkbook.Worksheets("Feuil1")
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\listeleve.xls")
    
        cr = Array(2, 3, 4, 5, 6, 7, 8)
        wsTarget.Range("B10").Resize(, 7).Value = Array("ر.ت", "الرمز", "النسب", "الاسم", "النوع", "تاريخ الازدياد", "مكان الازدياد")
    
        For Each wsSource In wb.Worksheets
            lr = wsSource.Cells(Rows.Count, "F").End(xlUp).Row
            arr = wsSource.Range("C16:AA" & lr).Value
            x = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
            j = 0
            
            For Each i In Array(25, 22, 15, 11, 10, 4, 1)
                wsTarget.Cells(x, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
                j = j + 1
            Next i
        Next wsSource
        
        wb.Close False
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

 

[ابو عمران]

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

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

[محمود أبوالدهب]

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

 

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

وشكرا جزيلا لك

 

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

بارك الله فيك أخي الكريم محمود ومشكور على سؤالك عني .. جزاك الله خيراً

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

 

[قصي]

جزاك الله خيرا استاذ ياسر

[محمود أبوالدهب]

 اشكرك استاذنا ياسر 

ولكن قمت بناء على هذا الفدو بعمل هذا الكود وايضا استعنت منه على كود قديم لسيادتكم والكود المصنوع هو 

    Sheets("INDEX").Range("A12:d" & Cells(Rows.Count, 1).End(xlUp).Row + 4).ClearContents
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
         If ws.Name <> "INDEX" And ws.Name <> "معاشات استثنائية" Then
                      ws.Range("a12:d36").Copy
                             With Sheets("INDEX")
                                 .Range("a" & .Cells(Rows.Count, 4).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                 ' هذا الجزء من الكود اوقفت لانى لا اعلم ما الخطأ فيه وما عملة فاحببت ان اسال صانعه
                                 '.Range("A" & .Cells(Rows.Count, 4).End(xlUp).Row + 1 & ":A" & .Cells(Rows.Count, 4).End(xlUp).Row) = Sheets(Item).Name
                             End With

           End If
  Next ws

ولكن الكود يعطينى خطا لانى لانى مخطاء فيه فارجوا ان اعرف من سيادتكم ما الخطأ وما حله ختى لا اقع فيه ثانيتا 

 

مهمت الكود انه يعمل كوبي للخلايا من a12:d36 ويضعهم في شيت index ويعيد الكره في جميع الشيات مع العلم انه يضع جميع البيانات اسفل بعضها لانى اريد تفعيله عن طريق chexbox حتى بعدها يسمح لى ببالبحث عن طريق listbox  بجميع البيانات الموجوده بملف العمل باكمله 

اتمنى الا اكون قد اطلة على سيادتكم 

تم تعديل أغسطس 2, 2017 بواسطه محمود أبوالدهب

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

أخي الكريم محمود 

ارفق الملف للإطلاع عليه فمن الصعب العمل على الكود بدون ملف مرفق .. ارفق الملف وسأحاول الإطلاع عليه في أقرب وقت إن شاء الله

[محمود أبوالدهب]

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

أخي الكريم محمود 

ارفق الملف للإطلاع عليه فمن الصعب العمل على الكود بدون ملف مرفق .. ارفق الملف وسأحاول الإطلاع عليه في أقرب وقت إن شاء الله

تفضل استاذى والفورم مربوط بزر في  شيت index

‏‏كشوف معاشات استثنائية - نسخة.rar

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

الخلية B38 في ورقة العمل INDEDX مدمجة وكذلك الخلية B39 والخلية B66 والخلية B67 ... وهذا هو سبب الخطأ .. أزل الدمج وجرب الكود مرة أخرى

وبالنظر إلى ورقة العمل INDEX أجدك قد قمت بعملية تسطير لنطاقات متباعدة .. ما الغرض من ذلك؟ الأفضل في بناء قواعد البيانات عدم ترك فواصل بين الصفوف .. 

[محمود أبوالدهب]

نعم استاذى الدمج كان سبب الخطأ واصبح الكود بعدهاا يعمل جيدا 

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

وعليه فتح الامر لى لاستفسار جديد الا وهو كيف يقوم الكو بتسطير النطاقات التى بها بيانات فقط عن نفسي اتبع تلك الاكواد وهى تضبط عرض العمود وحجم الخط ووإن كان blod ام لا  وعرض خط الجدول وهى

lrow = was.Range("a" & Rows.Count).End(xlUp).Row
.Range("A1:e" & lrow + 1).Borders.Weight = 3
.Columns("a:a").ColumnWidth = 15: was.Columns("b:b").ColumnWidth = 25
 .Cells.Font.Size = 12: was.Cells.Font.Bold = True

هل اظل اعمل بها يوجد طريقة افضل

 

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

وقد لاحظت اه برحل اسم الشيت " معاشات استثنائية " رغم انى لاغيه بالكود الاعلى منه اى المفروض لا يظهر نهائيا ولكن اذا غير مكان او ترتيب الورق يظهر الكود اختلاف بمكان ترحيل اسم الشيت

 والكود بعد التعديل هو 

    Sheets("INDEX").Range("A2:e" & Cells(Rows.Count, 1).End(xlUp).Row + 4).ClearContents
    Dim ws As Worksheet, sh As Worksheet, lrow As Long
      For Each ws In ThisWorkbook.Worksheets
     Set sh = Sheets("index")
     sh.Activate
     
            If ws.Name <> "INDEX" And ws.Name <> "معاشات استثنائية" Then
                ws.Range("a12:d36").Copy
                  With Sheets("INDEX")
                    .Range("a" & .Cells(Rows.Count, 4).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                    .Range("e" & .Cells(Rows.Count, 5).End(xlUp).Row + 1 & ":e" & .Cells(Rows.Count, 1).End(xlUp).Row) = ws.Name
                End With
            End If
     Next ws
  
lrow = sh.Range("a" & Rows.Count).End(xlUp).Row
sh.Range("A1:e" & lrow + 1).Borders.Weight = 3
sh.Columns("a:a").ColumnWidth = 12: sh.Columns("b:b").ColumnWidth = 35
sh.Columns("c:c").ColumnWidth = 20: sh.Columns("d:d").ColumnWidth = 20
sh.Columns("e:e").ColumnWidth = 20
sh.Cells.Font.Size = 12: sh.Cells.Font.Bold = True
End Sub

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

 

‏‏كشوف معاشات استثنائية - نسخة.rar

تم تعديل أغسطس 3, 2017 بواسطه محمود أبوالدهب

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

أخي الكريم محمود 

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

قم بالسؤال عن نقطة نقطة وحاول تدرس الأكواد التي تقدم في الموضوعات المختلفة .. وإن شاء الله مع الوقت تصبح محترفاً في التعامل بهذه الأكواد .. 

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

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

أعتذر عن عدم الإطالة .. وكما أخبرتك حاول أن تتناول أي استفسارات بشكل مبسط لكي يسهل الرد عليها .. وهذا لا يعني أننا نبخل بالمعلومة إنما أحب إعطاء المعلومة رويداً رويداً

تقبل تحياتي