جلب أسماء من شيتات مختلفة

[muneef]

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

ولو تكرمتم لدي ملف فيه ثلاث شيتات أحتاج نسخ الاسماء من الشيت الثاني والشيت الثالث إلى الشيت الأول مع مراعاة عدم تكرار الأسماء 

كما في المرفق

جلب الاسماء من عدة شيتات مع عدم التكرار.xlsx

[سليم حاصبيا]

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

Option Explicit

Sub All_in_One()
Dim First As Worksheet
Dim arr(1), Sh, i%
Dim dic As Object

Set First = Sheets("Sheet1")
Set dic = CreateObject("Scripting.Dictionary")
arr(0) = "Sheet2": arr(1) = "Sheet3"

First.Range("B1").CurrentRegion.ClearContents
 For Each Sh In arr
  i = 3
    Do Until Sheets(Sh).Range("B" & i) = vbNullString
  
     dic(Sheets(Sh).Range("B" & i).Value) = vbNullString
    i = i + 1
    Loop
  Next Sh
 
  If dic.Count Then
    First.Range("B2") = "Names"
      First.Range("B3").Resize(dic.Count) = _
      Application.Transpose(dic.keys)
      First.Range("A3").Resize(dic.Count) = _
      Evaluate("Row(1:" & dic.Count & ")")
 End If
 Set dic = Nothing: Set First = Nothing
 Erase arr
End Sub

الملف مرفق

Muneef.xlsm

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

بعد اذنك استاذ

خيار آخر

حتى بوجود فراغات

Sub test()
    Dim a, b As Variant, i
    a = Application.Transpose(Sheets("sheet2").Range("b3:b" & Sheets("sheet2").Cells(Rows.Count, 2).End(xlUp).Row))
    b = Application.Transpose(Sheets("sheet3").Range("b3:b" & Sheets("sheet3").Cells(Rows.Count, 2).End(xlUp).Row))
    a = Split(Join(a, "#") & "#" & Join(b, "#"), "#")
    With CreateObject("scripting.dictionary")
        For i = 0 To UBound(a)
            If a(i) <> "" Then
                If Not .exists(a(i)) Then
                    .Add a(i), .Count + 1
                End If
            End If
        Next
         Sheets("sheet1").Range(Sheets("sheet1").Range("a3"), Sheets("sheet1").Range("a3").End(xlDown)).Resize(, 2).ClearContents
        Sheets("sheet1").Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys))
    End With
End Sub

 

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

أكثر اختصاراً

Sub test()
    Dim a As Variant
    Dim i As Long
    Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim sh3 As Worksheet
    Set sh1 = Sheets("sheet1"): Set sh2 = Sheets("sheet2"): Set sh3 = Sheets("sheet3")
    a = Split(Join(Application.Transpose(sh2.Range("b3:b" & sh2.Cells(Rows.Count, 2).End(xlUp).Row)), "#") _
              & "#" & Join(Application.Transpose(sh3.Range("b3:b" & sh3.Cells(Rows.Count, 2).End(xlUp).Row)), "#"), "#")
    With CreateObject("scripting.dictionary")
        For i = 0 To UBound(a)
            If a(i) <> "" Then
                If Not .exists(a(i)) Then
                    .Add a(i), .Count + 1
                End If
            End If
        Next
        sh1.Range(sh1.Range("a3"), sh1.Range("a3").End(xlDown)).Resize(, 2).ClearContents
        sh1.Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys))
    End With
End Sub

 

جلب الاسماء من عدة شيتات مع عدم التكرار.xlsm

[muneef]

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

 

[سليم حاصبيا]

اذا كان هناك فراغات   يمكن ان نتجاوزها بهذا الكود

و لا لزوم لما لا يلزم من وضع 2 Arrays واحد لكل شيت

Option Explicit

Sub All_in_One()
Dim First As Worksheet
Dim arr(1), Sh, i%, x%
Dim dic As Object

Set First = Sheets("Sheet1")
Set dic = CreateObject("Scripting.Dictionary")
arr(0) = "Sheet2": arr(1) = "Sheet3"

First.Range("B1").CurrentRegion.ClearContents
 For Each Sh In arr
  x = Sheets(Sh).Cells(Rows.Count, 2).End(3).Row
  i = 2
    Do Until i > x
     If Sheets(Sh).Range("B" & i) <> "" Then
          dic(Sheets(Sh).Range("B" & i).Value) = vbNullString
     End If
     i = i + 1
    Loop
  Next Sh
 
  If dic.Count Then
    First.Range("B2") = "Names"
      First.Range("B3").Resize(dic.Count) = _
      Application.Transpose(dic.keys)
      First.Range("A3").Resize(dic.Count) = _
      Evaluate("Row(1:" & dic.Count & ")")
 End If
 Set dic = Nothing: Set First = Nothing
 Erase arr
End Sub

 

[muneef]

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

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

لكن المشكلة عندما طبقت الكود على الملف الخاص قام بمسح المعادلات في الشيت وللعلم الأعمدة من العمود ( c )  إلى العمود ( q )  فيها معادلات ولكن إذا كان العمود سي فارغ لا يمسح المعلومات والمعادلات في الاعمدة الثانيه

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

Muneef.xlsm