اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

EL_Naj3awy

بواسطه EL_Naj3awy
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

EL_Naj3awy

EL_Naj3awy

قام بنشر
قام بنشر (معدل)

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

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

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

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

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

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

 

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

تم تعديل بواسطه EL_Naj3awy
رابط هذا التعليق
شارك
ابراهيم الحداد

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

قام بنشر
قام بنشر

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك
EL_Naj3awy

EL_Naj3awy

قام بنشر
  • الكاتب
قام بنشر

الكود يعمل

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

الأولى

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

الثانية

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

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

 

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

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

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

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

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

رابط هذا التعليق
شارك
ابراهيم الحداد

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

قام بنشر
قام بنشر

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

تفضل 

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

 

  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

إلى 

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

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

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

 

رابط هذا التعليق
شارك
الأستاذ / محمد الدسوقى

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

قام بنشر
قام بنشر (معدل)

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

السلام عليكم

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

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

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

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

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

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

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

 

تم تعديل بواسطه الأستاذ / محمد الدسوقى
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

  • Like 1
رابط هذا التعليق
شارك
قصي

قصي

قام بنشر
قام بنشر
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

 

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

  • Like 1
رابط هذا التعليق
شارك
EL_Naj3awy

EL_Naj3awy

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

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

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

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

تم تعديل بواسطه EL_Naj3awy
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

رابط هذا التعليق
شارك
الأستاذ / محمد الدسوقى

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

قام بنشر
قام بنشر

أخى الكريم

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

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

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

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

رابط هذا التعليق
شارك
EL_Naj3awy

EL_Naj3awy

قام بنشر
  • الكاتب
قام بنشر

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

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

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

ثانيا

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

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

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

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

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

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

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

رابط هذا التعليق
شارك
  • أفضل إجابة
ياسر خليل أبو البراء

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

قام بنشر
  • أفضل إجابة
قام بنشر

أخي الكريم ..

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

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

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

 

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

أخي الكريم 

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

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept