a.kawkab

السلام عليكم
تفضل تم المطلوب
endsplash error.xlsm

تفضل اخى الكريم الملف بعد ازالة التحديد
كود نسخ البيانات.xlsm

السلام عليكم
اليك اخى الملف بعد التعديل وتنفيذ المطلوب
Hassan1.xlsm

السلام عليكم 
تفضل الشيت بعد التعديل يعمل جيدا
Test2.xlsm

السلام عليكم
تم التوصل الى الكود باقتباس من احد اعمال العلامة خبور
تم رفع الشيت بالكود للاستفادة وشكرا لكم
Private Sub CommandButton1_Click() ' أمر ترحيل بيانات Dim LR As Long Dim Adr As String Dim r As Integer, c As Integer ''''''''''''''''''''''''''''''' With Sh1 LR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 End With '''''''''' For r = 1 To 10 Adr = Cells(r, 1).Address(0, 0) For c = 1 To 5 Adr = Cells(r, c).Address(0, 0) Sh1.Range("A" & LR).Cells(r, c).Value = Me.Controls(Adr).Value Next Next '''''' End Sub  
Book101Add.xlsm

السلام عليكم
الدالة موجوده فى اوفيس 2021

وهذا ملفك الاساسى
خلفيتين مائيتين مختلفتين في صفحتين.xls

وعليكم السلام 
تفضل اخى الكود .... مرفق الملف
Sub export_sheets() Dim Fname As String, ws As Worksheet Application.DisplayAlerts = False Sheets(Array("2", "4", "6", "8", "10")).Copy For Each ws In ActiveWorkbook.Sheets ws.UsedRange = ws.UsedRange.Value Next ws ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "schoolclass " & NM, FileFormat:=51 ActiveWorkbook.Close Application.DisplayAlerts = True MsgBox "Done...", 64 End Sub  
School.xlsm

السلام عليكم 
اليك اخى الملف تم تنفيذ المطلوب
شاشة دخول.xlsm

السلام عليكم 
اليك اخى الملف لعله يفي بالمطلوب
data.xlsm

السلام عليكم 
اليك اخى الملف بعد تنفيذ المطلوب
قوائط الطالبات.xlsm

بعد اذن الاساتذة اليك المطلوب
ترحيل.xlsm

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("انسولين الهيئة", "انسولين الطلاب والرضع", "تقارير الاصناف")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True ' ' For Each ws In ActiveWorkbook.Worksheets ' ws.UsedRange.Value = ws.UsedRange.Value ' Next ws For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub  
تم تعديلالكود بواسطة الاستاذ ياسر خليل جزاه الله خيرا وتم المطلوب والحمد لله
وهذا الجزء هو ماتم تعديله
For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws  

اعضاء المنتدى الكرام
السلام عليكم
تم والحمد لله حل المشكلتين (1) و(3)وتبقت المشكلة الثانية الخاصة بتثبيت رؤؤس الاعمدة فى الليست بوكس
مرفق الملف بعد التعديل
الخاصية Column Heads إلى True كانت مفعلة بالفغل  وقد تم تدارك الخطا وهو ان رؤوس اغمدة البيانات كانت ضمن مدى rowsorce الليست بوكس لذلك كانت تتحرك مع البيانات  وبعد ضبط مدىrowsorce الليست  تم المطلوب وشكرا لكم
A.k.2020_08-01-2020.xlsm

تم تعديل الاستعلام بالحلقات التكرارية شكرا للاستاذ العيدروس لتعديله للكود وتم تنشيط رقم المسلسل ويعمل بانتطام
مرقق رابط مباشر للملف بعد التعديل الاخير
 
101استعلام عن طريق الاسم (4) .xlsm

السلام عليكم
اليك هذا الملف لعله يفى بالمطلوب
برنامج التقرير.xlsm