ترحيل البيانات من ورقة إلى ورقة خاصة حسب قاعدة معطيات

[nakiramar]

السلام عليكم ورحمة الله وبركاته الإخوة الأعزاء

لدي قاعدة معطيات كبيرة تتضمن جميع الطلبة (تزيد عن 2600) تتضمن ثلاث فئات: عربي - فرنسي - مزدوج

أريد عندما تصلني لائحة مختلطة من إحدى المؤسسات أن أقارنها مع قاعدة المعطيات وأقوم بترحيل الطلاب عربي إلى ورقة خاصة بالعربي والطلاب فرنسي إلى ورقة خاصة بالفرنسي والمزدوج كذلك

علما أن المقارنة يمكن أن تتم بالرقم أو الاسم

أريد كود برمجي VBA للترحيل

مشكورين مسبقا 

رمضان مبارك سعيد وكل عام وأنتم بألف خير

 

NOUVEAU.xlsm

[omar elhosseini]

هل الترحيل لجميع الطلاب ام للجدد فقط

[nakiramar]

السلام عليكم أخي عمر

فقط ترحيل الوافدين 

شكرا على تفاعلك أخي

 

[lionheart]

Sub Test()
    Dim a, x, e, v, wsData As Worksheet, wsExisting As Worksheet, wsA As Worksheet, wsF As Worksheet, wsM As Worksheet, sh As Worksheet, i As Long, ii As Long, k1 As Long, k2 As Long, k3 As Long, n As Long
    Application.ScreenUpdating = False
        Set wsData = ThisWorkbook.Worksheets("Data")
        Set wsExisting = ThisWorkbook.Worksheets("Feuil1")
        Set wsA = ThisWorkbook.Worksheets("ARABE")
        Set wsF = ThisWorkbook.Worksheets("FRANCAIS")
        Set wsM = ThisWorkbook.Worksheets("MIXTE")
        a = wsData.Range("A2:H" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value
        ReDim b1(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
        ReDim b2(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
        ReDim b3(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
        For i = LBound(a, 1) To UBound(a, 1)
            x = Application.Match(a(i, 1), wsExisting.Columns(1), 0)
            If Not IsError(x) Then GoTo NXT
            If a(i, 8) = "ARABE" Then
                k1 = k1 + 1
                For ii = 1 To 7
                    b1(k1, ii) = a(i, ii)
                Next ii
            ElseIf a(i, 8) = "FRANCAIS" Then
                k2 = k2 + 1
                For ii = 1 To 7
                    b2(k2, ii) = a(i, ii)
                Next ii
            ElseIf a(i, 8) = "MIXTE" Then
                k3 = k3 + 1
                For ii = 1 To 7
                    b3(k3, ii) = a(i, ii)
                Next ii
            End If
NXT:
        Next i
        For Each e In Array(1, 2, 3)
            If e = 1 Then
                Set sh = wsA: n = k1: v = b1
            ElseIf e = 2 Then
                Set sh = wsF: n = k2: v = b2
            ElseIf e = 3 Then
                Set sh = wsM: n = k3: v = b3
            End If
            If n > 0 Then
                sh.Range("A1").CurrentRegion.ClearContents
                sh.Range("A1").Resize(, 7).Value = wsData.Range("A1").Resize(, 7).Value
                sh.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
            End If
        Next e
    Application.ScreenUpdating = True
End Sub

 

[omar elhosseini]

ARABE

FRANCAIS

 

MIXTE

هذه الثلاث اقسام التي سيتم الترحيل اليها

ماذا تكون كل من

data Feuil1

[nakiramar]

بداية حفظكم الله ورعاكم أخي الفاضل

نعم أخي ARABE 

                     FRANCAIS

                     MIXTE

هي الأوراق التي أريد ترحيل البيانات الموجودة في الورقة Feuil1 إليها بعد مطابقتها بقاعدة المعطيات DATA

للتوضيح أكثر أخي: 

لا أريد ترحيل البيانات الموجودة في DATA

إنما الموجودة في Feuil1 المفروض أن أتوصل بها 

مع خالص تقديري

[omar elhosseini]

تقصد ان الورقة Feuil1

بها البيانات التي سترحل الي الاوراق الثلاثة بعد مقارنتها بالورقة  data

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

اذا كان هذا صحيح فكيف اميز البيانات التي ستنقل ( عربى فرنسي مختلط) عن بعض في الورقة Feuil1

 

[omar elhosseini]

اخي المشرف المحترم

كيف تم وضع علامة انه تم ايجابة المطوب من العضو والكود المقصود لا يؤدي الغرض

وهذا ليس اول مره كثير من الحلول التي تم وضع علامة الحل لا تؤدي المطلوب

ارجو مراعات الدقة حتي لا نفوت فرصة حصول العضو علي الحل المطلوب

[lionheart]

@omar elhosseini

Did you try the code to decide if it is working or not

The only one who can decide that is the OP not YOU

and when you call someone, call him with his name not just a member

[lionheart]

Sub Test()
    Dim x, ws As Worksheet, wsData As Worksheet, wsSource As Worksheet, wsA As Worksheet, wsF As Worksheet, wsM As Worksheet, r As Long, lr As Long
    Application.ScreenUpdating = False
        Set wsData = ThisWorkbook.Worksheets("Data")
        Set wsSource = ThisWorkbook.Worksheets("Feuil1")
        Set wsA = ThisWorkbook.Worksheets("ARABE")
        Set wsF = ThisWorkbook.Worksheets("FRANCAIS")
        Set wsM = ThisWorkbook.Worksheets("MIXTE")
        For Each ws In ThisWorkbook.Worksheets
            If ws Is wsA Or ws Is wsF Or ws Is wsM Then
                ws.Cells.ClearContents
                ws.Range("A1").Resize(, 7).Value = wsData.Range("A1").Resize(, 7).Value
            End If
        Next ws
        For r = 2 To wsSource.Cells(Rows.Count, 1).End(xlUp).Row
            x = Application.Match(wsSource.Cells(r, 1).Value, wsData.Columns(1), 0)
            If Not IsError(x) Then
                With ThisWorkbook.Worksheets(CStr(wsData.Cells(x, 8).Value))
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                    .Range("A" & lr).Resize(, 7).Value = wsSource.Range("A" & r).Resize(, 7).Value
                End With
            End If
        Next r
    Application.ScreenUpdating = True
End Sub

 

[omar elhosseini]

اخي lionheart

انا لا اقلل من شأنك ولكن اذا كان يؤدي المطلوب 

فلماذا قام العضو بالر علي استفسارتى

وانك وان لم اجرب الكود

واذا كان يؤدي المطلوب فأنا اسف مقدما وتقبل اعتذاري

 

[lionheart]

No worry my brother

I thought the OP selects the answer and not the moderator (How can I know such things?)

Sometimes the members take more than a solution so they continue to discuss

Ramadan Karim

[omar elhosseini]

اخي 

لقد قمت بتجربة الاكواد

اولا الكود الثاني غير الكود الاول تماما

الاول يرحل شيت data

وهذا غبر طلب العضو

الكود الثاني برحل شيت Feuil1

فلماذا المغالطة وتتأنيبي وانا سليم القول

[lionheart]

 

The OP is not clear in the issue and he doesn't respond properly

I have posted a nother different code based on his last comments

[محي الدين ابو البشر]

كما فهمت الموضوع

Sub Test()
    Range("H2").Formula = "=VLOOKUP($A$2:$A$13,data!$A$1:$H$540,8,0)"
    Range("H2").AutoFill Destination:=Range("H2:H" & Cells(Rows.Count, 1).End(xlUp).Row)
    a = Sheets("Feuil1").Cells(1).CurrentRegion
    For i = 2 To UBound(a)
        With Sheets(a(i, 8))
            x = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            For ii = 1 To UBound(a, 2)
                .Cells(x, ii) = a(i, ii)
            Next
        End With
    Next
    Range("H:H").ClearContents
End Sub

 

[nakiramar]

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

الإخوة كلكم مشكورين

هذا الكود لللأخ LIONHEART قلب الأسد يشتغل بشكل جيد