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

[أكسس وبس]

الاخوة الافاضل 

مرفق ملف اكسيل به ثلاث ورقات 

ورقة باسم اسماء العاملين وهى تشميل جميع المدارس بموظفيها

ورقة باسم طباعة كشف المدرسة 

ورقة باسم كشف المدرسة

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

الملف المرفق مثال لان اعداد المدارس تتخطى 120مدرسة وعدد العاملين 4300 

الرجاء المساعدة من اهل الخبرة اثابكم الله

سرى الشهادة الاعدادية.xlsx

[عبدالله بشير عبدالله]

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

تفضل واتمنى ان يحقق طلبك 

تم عمل قائمة اختيار (شاهد الصورة المرفقة) 

الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("N5")) Is Nothing Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        Dim wsSource As Worksheet
        Dim wsDest As Worksheet
        Dim schoolName As String
        Dim lastRow As Long
        Dim destRow As Long
        Dim i As Long

        Set wsSource = ThisWorkbook.Sheets("اسماء العاملين ")
        Set wsDest = ThisWorkbook.Sheets("طباعة كشف المدرسة")
        schoolName = Me.Range("N5").Value

        wsDest.Range("A9:Z" & wsDest.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents

        destRow = 9
        lastRow = wsSource.Cells(Rows.Count, "B").End(xlUp).Row

        For i = 7 To lastRow
            If wsSource.Cells(i, 6).Value = schoolName Then
                wsDest.Cells(destRow, 1).Value = destRow - 8
                wsDest.Cells(destRow, 2).Resize(, 4).Value = wsSource.Cells(i, 2).Resize(, 4).Value
                wsDest.Cells(destRow, 9).Value = wsSource.Cells(i, 6).Value
                destRow = destRow + 1
            End If
        Next i

        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
    End If
End Sub

الملف

سرى الشهادة الاعدادية.xlsb

 

سرى الشهادة الاعدادية.xlsb

تم تعديل نوفمبر 7 بواسطه عبدالله بشير عبدالله

[أكسس وبس]

اخى الكريم اشكرك على مرورك وردك الكريم

ولكن عند فتح الملف تظهر هذه الرسالة بضغط على yes لا يفتح الملف كما بالصورة التى ارسلتها حضرتك فى الرد ولكن يفتح الملف كما بالصورة الثانية ولا تظهر قائمة بالمدارس للطريقة التى اضفتها فى الملف عندى اوفيس 2007 فقط

[عبدالله بشير عبدالله]

 

الملف يعمل بدون مشاكل 

من خلال الصورة المرفقة بلدو ان اصدار الاوفيس 2007 

ان كان 2007 فالكود اعتقد لا يتوافق مع هذا الاصدار 

تم تعديل نوفمبر 7 بواسطه عبدالله بشير عبدالله

[أكسس وبس]

اخى اشكرك على اهتمامك وجزاك الله خيرا ولكن الاوفيس الى عندي 2007 طيب جربت الكود ما نفع هل هناك حل 

[عبدالله بشير عبدالله]

اتصحك بتحميل لصدار حديث لاته هناك دوال لا تعمل على الاصدارات القديمة

المشكلة في اصدار الاكسل لديك 

قمت يالتعدبل على الكود ليتوافق مع 2007 

جرب الملف المعدل 

 

سرى الشهادة الاعدادية.xlsb

 

تم تعديل نوفمبر 7 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

جرب هدا 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("N5")) Is Nothing Then
        Dim a As Variant, i As Long, k As Long, schoolName As String
        Dim n() As Variant, cnt As Long, count As Long, lr As Long, r As Long
        Dim WS As Worksheet: Set WS = Sheets("اسماء العاملين ")
        Dim dest As Worksheet: Set dest = Sheets("طباعة كشف المدرسة")

        schoolName = Me.Range("N5").Value
        If schoolName = "" Then Exit Sub

        a = WS.Range("A7:F" & WS.Cells(WS.Rows.count, "A").End(xlUp).Row).Value
        cnt = 0

        For i = 1 To UBound(a, 1)
            If a(i, 6) = schoolName Then
                cnt = cnt + 1
            End If
        Next i

        If cnt = 0 Then
            MsgBox "إسم المدرسة غير موجود في قاعدة البيانات", vbExclamation
            Exit Sub
        End If

        On Error Resume Next
        lr = dest.Columns("A:I").Find(What:="*", _
            SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        On Error GoTo 0
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        If lr >= 9 Then
            dest.Range("A9:E" & lr).ClearContents
            dest.Range("I9:I" & lr).ClearContents
        End If

        ReDim n(1 To cnt, 1 To 5)
        k = 1

        For i = 1 To UBound(a, 1)
            If a(i, 6) = schoolName Then
                n(k, 1) = k
                n(k, 2) = a(i, 2): n(k, 3) = a(i, 3)
                n(k, 4) = a(i, 4): n(k, 5) = a(i, 5)
                k = k + 1
            End If
        Next i
        
With dest
    .Cells(9, 1).Resize(cnt, 5).Value = n
    .Cells(9, 9).Resize(cnt, 1).Value = schoolName
     count = Application.WorksheetFunction.CountA(.Range("B9:B" & _
    .Cells(.Rows.count, "B").End(xlUp).Row))
    .[H4].Value = count
End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    End If
End Sub

 

سرى الشهادة الاعدادية.xlsb

تم تعديل نوفمبر 8 بواسطه محمد هشام.

[أكسس وبس]

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

في 7‏/11‏/2024 at 20:22, عبدالله بشير عبدالله said:

تصحك بتحميل لصدار حديث لاته هناك دوال لا تعمل على الاصدارات القديمة

المشكلة في اصدار الاكسل لديك 

قمت يالتعدبل على الكود ليتوافق مع 2007 

جرب الملف المعدل 

 

في 8‏/11‏/2024 at 04:04, محمد هشام. said:

جرب هدا 

نفس المشكلة لم يفتح الملف على المطلوب هو المطلوب اوفيس اصدار كام ؟

[محمد هشام.]

قم بتحميل الملف مرة أخرى بعد التعديل ووافينا بالنتيجة 

أعتقد أن المشكلة لديك ليس في نسخة الأوفيس  حيث أن جميع الدوال والميزات المستخدمة في الكود مدعومة في Excel 2007

 

[أكسس وبس]

في 8‏/11‏/2024 at 13:54, محمد هشام. said:

م بتحميل الملف مرة أخرى بعد التعديل ووافينا بالنتيجة 

أعتقد أن المشكلة لديك ليس في نسخة الأوفيس  حيث أن جميع الدوال والميزات المستخدمة في الكود مدعومة في Excel 2007

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

[محمد هشام.]

جرب تحميل نسخة أحدث 

https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file

[أكسس وبس]

في 8‏/11‏/2024 at 14:25, محمد هشام. said:

جرب تحميل نسخة أحدث 

تسلم ربنا يبارك فيك اللاب الى عندى ويندز 7 32بت مش حينفع معاه الاصدارات الحديثة للاسف امكانياتي محدوده للاسف

[محمد هشام.]

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

 

 

 

تم تعديل نوفمبر 8 بواسطه محمد هشام.

[أكسس وبس]

ينفع اوفيس 2013 عندى اوفيس 2013 بس لغيته ؟

[محمد هشام.]

نعم أظن أن نسخة 2013 تشتغل على Windows 7 Service Pack 1 وما فوق 

[أكسس وبس]

في 8‏/11‏/2024 at 14:47, محمد هشام. said:

نعم أظن أن نسخة 2013 تشتغل على Windows 7 Service Pack 1 وما فوق 

جزاكم الله خيرا خلاص حجرب تفعيل اوفيس 2013 وان شاء الله حجرب ملف حضرتك وملف الاستاذ عبدالله بشير عبدالله 

والله المستعان

[أكسس وبس]

الحمدلله بعد تفعيل اوفيس 2013 نفع الملف وبارك الله فيكم وعليكم

لى طلب فى نفس الملف اريد تحديد عملية الطباعة للجدول فى ورقة طباعة كشف المدرسة بمعنى لو البيانات فى الجدول تكفى ورقة واحدة يطبع تلقائي الورقة بعينها ولو البيانات فى الجدول تكفى لورقتين او ثلاث يتم طباعة الجدول تلقائي بدون تحديد عدد الورق فى نفس الوقت الحفاظ على البيانات وروؤس الجدول والبيانات التى فى الاسفل للتوقييعات

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

[عبدالله بشير عبدالله]

نفضل كود الطباعة

سرى الشهادة الاعدادية (2).xlsb

[أكسس وبس]

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