أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة YasserKhalil الترقيم بشرط معين اكسيل اسئله واجابات


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





مساعده فى كود

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


موضوع مغلق


subject icon تمت الإجابة مساعده فى كود
10-09-2021 12:38 مساء
omaryoseeg
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 10-09-2021
رقم العضوية : 22859
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 0-12-1980
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 17
 offline 

السلام عليكم احتاج مساعده فى انشاء vba خاص فى ورقه عمل يربط بين رقم الطالب والبيانات الخاصه وجلبها من اكثر من ورقه عمل مثل تاريخ الميلاد ومحل الميلاد والتقدير والرقم القومي وهذى البيانات متوفره لكن استخدام داله lookup or vlookup يظهر فى اوقات كثيرا من الاخطاء 
انتبه من فضلك فقد تـــم تعديل واعادة رفع الملف بإمتداد يقبل الأكواد .. طالما انك تريد حل مشكلتك بالأكواد XLSM
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
XLSM
 
 
 
  مساعده.xlsm   تحميل xlsm مرات التحميل :(10)
الحجم :(18.152) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
وعليكم السلام
جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Dim x, y, ws1 As Worksheet, ws2 As Worksheet, sh As Worksheet, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Worksheets(1)
        Set ws1 = ThisWorkbook.Worksheets(2)
        Set ws2 = ThisWorkbook.Worksheets(3)
        lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
        With sh.Range("C2:O" & lr)
            .ClearContents: .Borders.Value = 0
        End With
        sh.Columns(14).NumberFormat = "#"
        For i = 2 To lr
            x = Application.Match(sh.Cells(i, 2).Value, ws1.Columns(1), 0)
            If Not IsError(x) Then
                sh.Cells(i, 3).Value = ws1.Cells(x, 3).Value
                sh.Cells(i, 4).Value = ws1.Cells(x, 6).Value
                sh.Cells(i, 6).Value = ws1.Cells(x, 5).Value
                sh.Cells(i, 7).Value = ws1.Cells(x, 7).Value
                sh.Cells(i, 8).Value = ws1.Cells(x, 9).Value
                sh.Cells(i, 13).Value = ws1.Cells(x, 10).Value
                sh.Cells(i, 14).Value = ws1.Cells(x, 8).Value
            End If
            y = Application.Match(sh.Cells(i, 2).Value, ws2.Columns(2), 0)
            If Not IsError(y) Then
                sh.Cells(i, 9).Value = ws2.Cells(y, 4).Value
                sh.Cells(i, 10).Value = ws2.Cells(y, 6).Value
                sh.Cells(i, 11).Value = ws2.Cells(y, 5).Value
                sh.Cells(i, 12).Value = ws2.Cells(y, 7).Value
                sh.Cells(i, 15).Value = ws2.Cells(y, 8).Value
            End If
        Next i
        With sh.Range("B2:O" & lr)
            .Borders.Value = 1
        End With
    Application.ScreenUpdating = True
End Sub
عرض الإجابة




10-09-2021 01:48 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif مساعده فى كود
وعليكم السلام
جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Dim x, y, ws1 As Worksheet, ws2 As Worksheet, sh As Worksheet, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Worksheets(1)
        Set ws1 = ThisWorkbook.Worksheets(2)
        Set ws2 = ThisWorkbook.Worksheets(3)
        lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
        With sh.Range("C2:O" & lr)
            .ClearContents: .Borders.Value = 0
        End With
        sh.Columns(14).NumberFormat = "#"
        For i = 2 To lr
            x = Application.Match(sh.Cells(i, 2).Value, ws1.Columns(1), 0)
            If Not IsError(x) Then
                sh.Cells(i, 3).Value = ws1.Cells(x, 3).Value
                sh.Cells(i, 4).Value = ws1.Cells(x, 6).Value
                sh.Cells(i, 6).Value = ws1.Cells(x, 5).Value
                sh.Cells(i, 7).Value = ws1.Cells(x, 7).Value
                sh.Cells(i, 8).Value = ws1.Cells(x, 9).Value
                sh.Cells(i, 13).Value = ws1.Cells(x, 10).Value
                sh.Cells(i, 14).Value = ws1.Cells(x, 8).Value
            End If
            y = Application.Match(sh.Cells(i, 2).Value, ws2.Columns(2), 0)
            If Not IsError(y) Then
                sh.Cells(i, 9).Value = ws2.Cells(y, 4).Value
                sh.Cells(i, 10).Value = ws2.Cells(y, 6).Value
                sh.Cells(i, 11).Value = ws2.Cells(y, 5).Value
                sh.Cells(i, 12).Value = ws2.Cells(y, 7).Value
                sh.Cells(i, 15).Value = ws2.Cells(y, 8).Value
            End If
        Next i
        With sh.Range("B2:O" & lr)
            .Borders.Value = 1
        End With
    Application.ScreenUpdating = True
End Sub



الكلمات الدلالية
مساعده ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 08:48 صباحا