ترحيل واستخراج بيانات

[رجب مرسي]

من فضلكم عندي جدول في اكسل مكون من 15 عمود وحوالى 5000 صف تحتوي على بيانات مدرسين

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

فهرس مايو عام11 2024.xlsx

[Saleh Ahmed Rabie]

يمكنك الاستفادة من هذا الكود التالي:

Sub ExtractNumbers()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim number As String
    Dim targetRange As Range
    Dim uniqueNumbers As New Collection
    Dim duplicateNumbers As New Collection
    Dim answer As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "M").End(xlUp).Row
    Set targetRange = ws.Range("R2:R" & lastRow)
    
    For Each cell In ws.Range("M2:M" & lastRow)
        number = cell.Value
        If IsNumeric(number) Then
            If Not uniqueNumbers.Contains(number) Then
                uniqueNumbers.Add number
                targetRange.Cells(uniqueNumbers.Count, 1).Value = number
            Else
                duplicateNumbers.Add number
            End If
        End If
    Next cell
    
    answer = MsgBox("عدد الأرقام القومية المستخرجة هو: " & uniqueNumbers.Count & vbCrLf & _
                    "هل تريد الترحيل بدون تكرار الأرقام؟" & vbCrLf & vbCrLf & _
                    "اختر موافق للترحيل بدون تكرار" & vbCrLf & _
                    "اختر إلغاء لحذف الأرقام المكررة" & vbCrLf & _
                    "اختر لا لتلوين الأرقام المكررة باللون الأحمر", vbYesNoCancel)
    
    If answer = vbYes Then
        ' ترحيل بدون تكرار
    ElseIf answer = vbNo Then
        ' حذف الأرقام المكررة
        For Each num In duplicateNumbers
            ws.Range("R2:R" & lastRow).Replace num, ""
        Next num
    ElseIf answer = vbCancel Then
        ' تلوين الأرقام المكررة باللون الأحمر
        For Each num In duplicateNumbers
            Set foundCell = ws.Range("R:R").Find(What:=num, LookIn:=xlValues, LookAt:=xlWhole)
            foundCell.Font.Color = RGB(255, 0, 0)
        Next num
    End If
End Sub

يمكنك تنفيذ هذا الكود عن طريق الذهاب إلى قائمة "مطور" ثم اختيار "ماكرو" وتحديد الكود وتشغيله. سيقوم الكود بإستخراج الأرقام القومية من العمود M وترحيلها إلى العمود R مع عمل رسالة تنبيه بعدد الأرقام المستخرجة وثلاثة خيارات لعملية الترحيل.

يرجى التأكد من حفظ العمود R قبل تنفيذ الكود حيث سيتم كتابة الأرقام القومية في هذا العمود.

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

Sub ExtractNumbers()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim number As String
    Dim targetRange As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "M").End(xlUp).Row
    Set targetRange = ws.Range("R2:R" & lastRow)
    
    For Each cell In ws.Range("M2:M" & lastRow)
        number = cell.Value
        If IsNumeric(number) Then
            targetRange.Cells(cell.Row - 1, 1).Value = number
        End If
    Next cell
End Sub

 

ويمكنك استخدام معادلة بدلاً من كود VBA. 

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

2. اكتب العمود R الذي تريد نقل الأرقام القومية إليه.

3. في الخلية R2، اكتب الصيغة التالية:
   

  =IF(ISNUMBER(M2), M2, "")

4. اضغط على Enter لتطبيق الصيغة. يتم الآن اختبار قيمة الخلية في العمود M. إذا كانت القيمة رقمية، سيتم نقلها إلى العمود R. إذا لم تكن القيمة رقمية، ستكون الخلية فارغة.

5. سحب الزاوية السفلى اليمنى من الخلية R2 إلى الأسفل حتى الصف الأخير الذي يحتوي على بيانات في العمود M.

بهذه الطريقة، يتم استخدام معادلة Excel بسيطة لاستخراج الأرقام القومية من العمود M ونقلها إلى العمود R دون الحاجة إلى استخدام كود VBA.

تم تعديل مايو 31 بواسطه Saleh Ahmed Rabie
اضافة

[رجب مرسي]

لعلي لم اوفق في طرخ السؤال 

انا اريد استخراج ما اضعة من بداية الخلية  R5   من الشيت الاساسي  A1:O5000 على ان ينسخ لي  البيانات التي تخص الرقم القومي الذي وضعتة   من بداية الخلية  V5 الى الخلية AJ5

فهرس مايو عام11 2024.xlsx

تم تعديل يونيو 1 بواسطه رجب مرسي

[حسونة حسين]

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

تفضل اخي

Option Explicit

Sub Search_Transfer()
    Dim WS As Worksheet, cel As Range, lr As Long, Temp(), I As Long, J As Long, X
    Set WS = ThisWorkbook.Worksheets("Sheet2")
    lr = WS.Cells(Rows.Count, "R").End(xlUp).Row
    For Each cel In WS.Range("R5:R" & lr)
        If cel <> "" Then
            X = Application.Match(cel, WS.Columns(13), 0)
            If Not IsError(X) Then
                I = I + 1
                ReDim Preserve Temp(1 To 15, 1 To I)
                Temp(1, I) = I
                For J = 2 To 15
                    Temp(J, I) = WS.Cells(X, J).Value
                Next J
            End If
        End If
    Next cel
    Temp = Application.Transpose(Temp)
    If I > 0 Then WS.Range("V5").Resize(I, UBound(Temp, 2)).Value2 = Temp
End Sub

 

[رجب مرسي]

رائع رائع رائع هو المطلوب بالضبط بارك الله في صحتك انت ومن تحب

تم تعديل يونيو 2 بواسطه رجب مرسي

[علي بطيخ سالم]

الحمد لله الذي بنعمته تتم الصالحات

 

[hafez81]

ممتاز