طلب كود ترحيل لأعمدة غير متتالية وغير مرتبة

EL_Naj3awy · أغسطس 10, 2017

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

قمت بعمل ملف أكسيل يقوم بمعظم أعمال شئون الطلاب المدرسية

ينقصنى فيه بعض أكواد الترحيل

الكود المطلوب

( كود لترحيل البيانات من صفحة ( بيانات الطلاب ) إلى صفحة ( سجل 41 مستجدين

طبعا يجب أن يكون التلميذ مستجد أو مستجدة

شئون الطلاب 2018.rar

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

**ابراهيم الحداد** · أغسطس 10, 2017

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

استخدم هذا الكود

Sub Tra_Data()
Dim ws As Worksheet, sh As Worksheet
Dim LR As Long, i As Long, j As Long, p As Long
Dim Arr As Variant, Temp As Variant
Set ws = Sheets("بيانات الطلاب")
Set sh = Sheets("سجل 41 مستجدين")
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
Arr = ws.Range("B17:T" & LR).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If True Then
p = p + 1
For j = 1 To 13
Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 10, 11, 12, 13, 14, 16, 17)) = Arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 13, 4, 14, 15, 16, 11, 12))
Next
End If
Next
If p > 0 Then sh.Range("B8").Resize(p, UBound(Temp, 2)).Value = Temp

End Sub

EL_Naj3awy · أغسطس 10, 2017

الكود يعمل

ولكن هناك ملحوظتان فقط

الأولى

تم إضافة خانة للمجموع فى بيانات الطلاب أرجو ترحيلها مع باقى البيانات

الثانية

الكود يرحل جميع الطلاب وهذا خطأ

المرجو ترحيل الطلاب المستجدين فقط

أرجو تعديل الكود طامعاً فى سعة صدركم

تم إرفاق الملف الجديد فى المرفقات

شئون الطلاب 6.rar

للأسف نسيت وضع بعض الأسماء للتجربة عليها

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

**ابراهيم الحداد** · أغسطس 10, 2017

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

تفضل

Sub Tra_Data()
Dim ws As Worksheet, sh As Worksheet
Dim LR As Long, i As Long, j As Long, p As Long
Dim Arr As Variant, Temp As Variant
Set ws = Sheets("بيانات الطلاب")
Set sh = Sheets("سجل 41 مستجدين")
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
Arr = ws.Range("C17:T" & LR).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 4) = "مستجد" Then
p = p + 1
For j = 1 To 13
Temp(p, Choose(j, 1, 2, 3, 4, 5, 9, 10, 11, 12, 13, 15, 16, 17)) = Arr(i, Choose(j, 1, 6, 7, 8, 9, 12, 3, 13, 14, 15, 10, 11, 16))
Cells(p + 7, "B") = p
Next
End If
Next
If p > 0 Then sh.Range("C8").Resize(p, UBound(Temp, 2)).Value = Temp

End Sub

EL_Naj3awy · أغسطس 10, 2017

تتبقى مشكلة واحدة

وهى ترحيل الطالبة المستجدة

الكود يرحل مستجد فقط

أريده أن يرحل مستجدة أيضا

تقبل تحياتى مسبقا

ياسر خليل أبو البراء · أغسطس 10, 2017

جرب تغير السطر التالي

If Arr(i, 4) = "مستجد" Then

إلى

If Arr(i, 4) Like "مستجد" Then

EL_Naj3awy · أغسطس 10, 2017

للأسف لم يفلح

كما يظهر ترقيم تلقائى فى صفحة بيانات الطلاب أريد إيقافه

وذلك عند الترحيل الى سجل 41 مستجدين

EL_Naj3awy · أغسطس 10, 2017

للأسف لم يفلح

كما يظهر ترقيم تلقائى فى صفحة بيانات الطلاب أريد إيقافه

وذلك عند الترحيل الى سجل 41 مستجدين

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

ياسر خليل أبو البراء · أغسطس 10, 2017

استبدل السطر التالي

If Arr(i, 4) = "مستجد" Then

إلى

If Instr(Arr(i, 4), "مستجد*") > 0 Then

واحذف سطر الترقيم

Cells(p + 7, "B") = p

EL_Naj3awy · أغسطس 10, 2017

للأسف لم يفلح

أرجو منكم تحملى حتى انتهاء هذه المشاكل

ياسر خليل أبو البراء · أغسطس 10, 2017

ارفق الملف النهائي للإطلاع عليه ومعرفة أين الخلل؟

EL_Naj3awy · أغسطس 10, 2017

هذا هو الملف النهائى حتى الآن فى المرفقات

ملحوظة

مازال العمل جارى على الملف

شئون الطلاب 7.rar

الأستاذ / محمد الدسوقى · أغسطس 10, 2017

الأخوة الكرام

السلام عليكم

هذا كود يقوم بنقل الأعمدة غير المتتالية من ورقة عمل ( المصدر ) إلى أعمدة غير متتالية فى ورقة الهدف )

قد يفيد فى حل المشكلة ــــــــــــــــــ الكود شغال على كل الطلبة ـــــــــــ فهنا المشكلة :

المشكلة أريد وضع شرط بالكود وهو نقل الطلاب المستجدين ( مستجد ـ مستجدة ) حسبما يريد طالب السؤال

فأين يوضع الشرط فى الكود

أرجــــو منكم الإفادة للجميع

تقبلوا تحياتى

Option Explicit
Sub Students_Record()

'-----------------------------------
   ' سجل قيد الطلاب المستجدين
'-----------------------------------
  Dim Arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long

Dim LR As Long
'ترحيل بيانات سجل القيد
'----------------------------------
Dim ws As Worksheet, Sh As Worksheet
Set Sh = Sheets("بيانات الطلاب") 'المصدر
Set ws = Sheets("سجل قيد الطلاب المستجدين") 'الهدف
LR = Sh.Cells(Rows.Count, 3).End(xlUp).Row
'----------------------------------
Application.ScreenUpdating = False

ws.Range("C11:C510,E11:P510").ClearContents
Arr = Sh.Range("A17:T" & LR).Value 
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 6, 7, 11, 12, 13, 15, 16)        
    'أرقام الأعمدة المطلوب ترحيلها           
    For Each i In Array(3, 8, 9, 10, 14, 5, 6, 12, 13)      
        Sheets("سجل قيد الطلاب المستجدين").Cells(11, cr(j)).Resize(UBound(Arr, 1)).Value = Application.Index(Arr, , i)
        j = j + 1
          
        Next i
    Application.ScreenUpdating = True
End Sub

تم تعديل أغسطس 10, 2017 بواسطه الأستاذ / محمد الدسوقى

ياسر خليل أبو البراء · أغسطس 11, 2017

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

**قصي** · أغسطس 11, 2017

9 ساعات مضت, الأستاذ / محمد الدسوقى said:
الأخوة الكرام

السلام عليكم

هذا كود يقوم بنقل الأعمدة غير المتتالية من ورقة عمل ( المصدر ) إلى أعمدة غير متتالية فى ورقة الهدف )

قد يفيد فى حل المشكلة ــــــــــــــــــ الكود شغال على كل الطلبة ـــــــــــ فهنا المشكلة :

المشكلة أريد وضع شرط بالكود وهو نقل الطلاب المستجدين ( مستجد ـ مستجدة ) حسبما يريد طالب السؤال

فأين يوضع الشرط فى الكود

أرجــــو منكم الإفادة للجميع

تقبلوا تحياتى
Option Explicit
Sub Students_Record()

'-----------------------------------
   ' سجل قيد الطلاب المستجدين
'-----------------------------------
  Dim Arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long

Dim LR As Long
'ترحيل بيانات سجل القيد
'----------------------------------
Dim ws As Worksheet, Sh As Worksheet
Set Sh = Sheets("بيانات الطلاب") 'المصدر
Set ws = Sheets("سجل قيد الطلاب المستجدين") 'الهدف
LR = Sh.Cells(Rows.Count, 3).End(xlUp).Row
'----------------------------------
Application.ScreenUpdating = False

ws.Range("C11:C510,E11:P510").ClearContents
Arr = Sh.Range("A17:T" & LR).Value 
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 6, 7, 11, 12, 13, 15, 16)        
    'أرقام الأعمدة المطلوب ترحيلها           
    For Each i In Array(3, 8, 9, 10, 14, 5, 6, 12, 13)      
        Sheets("سجل قيد الطلاب المستجدين").Cells(11, cr(j)).Resize(UBound(Arr, 1)).Value = Application.Index(Arr, , i)
        j = j + 1
          
        Next i
    Application.ScreenUpdating = True
End Sub

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

ياسر خليل أبو البراء · أغسطس 11, 2017

أخي الكريم قصي شاهد الفيديو التالي عله يفيدك

EL_Naj3awy · أغسطس 11, 2017

أكيد فى حل للموضوع ده

مش معقولة مفيش حل

وبعد إذن الأستاذ ياسر خليل أبو البراء

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

فيس أو ماسنجر أو رقم تليفون

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

ياسر خليل أبو البراء · أغسطس 11, 2017

أخي الكريم عند إرفاق ملف يراعى أن توجد بعض البيانات للعمل عليها وتجربة الأكواد

قمت بتحميل الملف ولم أجد بيانات في ورقة العمل "بيانات الطلاب" ضع بعض البيانات للعمل عليها بحيث تكون معبرة عن الملف الأصلي ولا تضع الكثير من البيانات .. يكفي 20 صف للعمل عليهم وتجربة الأكواد ...

EL_Naj3awy · أغسطس 11, 2017

مرفق ملف ببيانات 20 تلميذ

شئون الطلاب 8.rar

**قصي** · أغسطس 11, 2017

سطر المسح من اهم الاسطر في مثل هذه الاكواد ..

ws.Range("C11:C510,E11:P510").ClearContents

الأستاذ / محمد الدسوقى · أغسطس 11, 2017

أخى الكريم

يوجد بعض البيانات المطلوب ترحيلها إلى ( سجل قيد الطلاب المستجدين ) غير موجودة بورقة العمل ( بيانات الطلاب )

مثل : اسم والد الطالب ـ السن فى أول اكتوبر

فكيف يمكن نقلها من ورقة بيانات الطلاب وهى أصلا ليست موجودة

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

EL_Naj3awy · أغسطس 11, 2017

أستاذنا الفاضل الأستاذ / محمد الدسوقى

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

بداية هذا الموضوع خاص بترحيل البيانات إلى سجل 41 مستجدين

ثانيا

بالنسبة لاسم والد الطالب والسن فى أول أكتوبر

جارى تجهيز الدوال الخاصة بهم وسوف يتم وضعها فى سجل 41 مستجدين

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

المشكلة حاليا أنى أريد ترحيل الطلاب الذين حالة القيد لديهم

مستجد أو مستجدة

إلى سجل 41 مستجدين

وسوف يتم حل باقى المشاكل تباعا

ياسر خليل أبو البراء · أغسطس 11, 2017

أخي الكريم ..

إليك الكود التالي .. لا حاجة للاحتفاظ بالمعادلات في ورقة الهدف (النتائج) .. حيث وضعت لك دوال معرفة تقوم بنفس المهمة .. وتوفر عليك عناء كتابة وضبط المعادلات ..

أدرج موديول جديد .. ثم ضع الكود التالي وجرب الكود وأخبرنا بالنتائج

Option Explicit

Sub TransferDataUsingArrays()
    Const startDate     As Date = #10/1/2017#
    
    Dim ws              As Worksheet
    Dim sh              As Worksheet
    Dim arr             As Variant
    Dim temp            As Variant
    Dim birthDate       As Date
    Dim i               As Long
    Dim j               As Long
    Dim p               As Long

    Set ws = Sheets("بيانات الطلاب")
    Set sh = Sheets("سجل 41 مستجدين")

    arr = ws.Range("B17:T" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value
    ReDim temp(1 To UBound(arr, 1), 1 To 18)

    For i = 1 To UBound(arr, 1)
        If arr(i, 5) = "مستجد" Or arr(i, 5) = "مستجدة" Then
            p = p + 1
            For j = 1 To 18
                temp(p, j) = arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 7, 8, 9, 13, 4, 14, 15, 16, 2, 11, 12, 17))
            Next j
            temp(p, 1) = p
            
            On Error Resume Next
                birthDate = CDate(temp(p, 3) & "/" & temp(p, 4) & "/" & temp(p, 5))
                temp(p, 7) = CalculateAge(birthDate, startDate, "d")
                temp(p, 8) = CalculateAge(birthDate, startDate, "m")
                temp(p, 9) = CalculateAge(birthDate, startDate, "y")
            On Error GoTo 0
            
            temp(p, 15) = KhFatherName(CStr(temp(p, 2)))
        End If
    Next i

    If p > 0 Then
        With sh.Range("B8")
            .Resize(1000, UBound(temp, 2)).ClearContents
            .Resize(p, UBound(temp, 2)).Value = temp
        End With
    End If
End Sub

Function KhFatherName(ByVal Name As String) As String
    Dim khString        As String
    Dim searchChar      As String
    Dim khMid           As String
    Dim khRep           As String
    Dim khMyNo          As Integer

    On Error GoTo Err_KhFatherName

    If IsEmpty(Name) Then GoTo Err_KhFatherName
    khString = KhFatherReplace(Trim(Name)) & " "
    searchChar = " "
    khMyNo = InStr(1, khString, searchChar, 1)
    khMid = Trim(Mid(khString, khMyNo, Len(khString)))
    khRep = Replace(khMid, "_", " ")
    KhFatherName = khRep

    Exit Function

Err_KhFatherName:
    KhFatherName = ""
End Function

Private Function KhFatherReplace(ByVal Kh_Sub As String) As String
    Dim myArray         As Variant
    Dim ar              As Variant
    Dim sn              As String
    Dim re              As String

    myArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", " الزهراء")
    sn = Kh_Sub
    
    For Each ar In myArray
        re = Replace(ar, " ", "_")
        sn = Replace(sn, ar, re)
    Next ar
    
    KhFatherReplace = sn
End Function

Function CalculateAge(birth As Variant, start As Variant, str As String)
    Dim y               As Long
    Dim m               As Long
    Dim d               As Long

    If Not IsDate(birth) Or Not IsDate(start) Then GoTo Skipper

    m = DateDiff("m", birth, start)
    d = DateDiff("d", DateAdd("m", m, birth), start)
    If d < 0 Then
        m = m - 1
        d = DateDiff("d", DateAdd("m", m, birth), start)
    End If
    y = m \ 12
    m = m Mod 12

    Select Case str
        Case "d"
            CalculateAge = d
        Case "m"
            CalculateAge = m
        Case "y"
            CalculateAge = y
    End Select

    Exit Function

Skipper:
    CalculateAge = ""
End Function

EL_Naj3awy · أغسطس 11, 2017

بارك الله فيك

فعلا كود سحرى للملف

ياسلام بقى لو كود تانى زى ده لسجل قيد الطلاب المستجدين

وبكرر تانى

ياريت وسيلة اتصال أسرع مع حضرتك

ياسر خليل أبو البراء · أغسطس 11, 2017

أخي الكريم

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

وحاول تدرس الأكواد المقدمة لاستغلالها في أمور أخرى ... فقد يمكنك استغلال كود واحد لتنفيذ مهام متعددة .. وفقني الله وإياك الله لكل خير

تسجيل الدخول

طلب كود ترحيل لأعمدة غير متتالية وغير مرتبة

الردود الموصى بها

EL_Naj3awy

ابراهيم الحداد

EL_Naj3awy

ابراهيم الحداد

EL_Naj3awy

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

EL_Naj3awy

EL_Naj3awy

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

EL_Naj3awy

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

EL_Naj3awy

الأستاذ / محمد الدسوقى

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

قصي

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

EL_Naj3awy

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

EL_Naj3awy

قصي

الأستاذ / محمد الدسوقى

EL_Naj3awy

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

EL_Naj3awy

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

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information