معادلة جلب اسم الشركة بين تاريخين وبدون تكرار

[هانى محمد]

السلام عليكم أحبائى وأساتذتى الكرام ... أرجو التكرم على مساعدتى فى ايجاد وجلب اسم الشركة الموجودة بالعمود الثالث C من صفحة Main الى العمود الأول A بصفحة Final بناءاً على التواريخ الموجودة بالعمودين B & C من نفس الصفحة على ان يكون اسم الشركة بهذان التاريخين مرة واحدة اى بدون تكرار , ولكم جزيل الشكر

Company.xlsm

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

جرب هذا الملف

 

Company_Repprt.xlsm

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

انت هنا تجدد:
            اول 3 صفوف للتاريخ  من 1/7/2020  الى 31/7/2020 وما ادراك ان العدد سيكون 3 شركات؟؟؟
            ومن الصف 5 الى الصف 10 للتاريخ  من 1/8/2020  الى 31/8/2020 وما ادراك ان العدد سيكون 6 شركات؟؟؟
ربما ينفع احد هذين الملفين (الرجاء ابلاغي ايهما تريد لا تقل الاول او الثّاني اريد تسمية الملف)

 

Company_Repprt_ExPlicit.xlsm

Hani.xlsm

[هانى محمد]

ممتاز استاذ سليم بارك الله فيك ولكن ممكن ملاحظة هذه المشكلة فتم تغيير تاريخين فقط للشركات فى شهر سبتمبر 2020 ولكن كما ترى بالملف بعد تنفيذ الكود أعطانى أكثر من اسم والأصح والمفروض ان يعطينى هذان الإسمان فقط 

King Travel

Agency Travel

Hani.xlsm

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

تم معالجة الأمر بعد تطوير الكود
ليطعي رسالة خطأ اذا كانت احد الخلايا في العامودين  D و  E  لا تصلح كتاريخ (أو فارغة)

Hani_Exact.xlsm

[هانى محمد]

أحسنت استاذ سليم عمل ممتاز بارك الله فيك وزادك الله من فضله وأدخلك فسيح جناته ... وهو بالفعل المطلوب

جزاك الله كل خير ونصر الله لبنان وشعبها

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

أكثر من ذلك تم تطوير الكود بحيث تظهر النتائج في عامود واحد مع ترقيمها

Option Explicit
    Dim F As Worksheet, M As Worksheet
    Dim L_M%, L_F%, K%, t%, xx%, A%
    Dim x As Boolean, y As Boolean, z As Boolean
    Dim D1 As Date, D2 As Date
    Dim Obj As Object
 '++++++++++++++++++++++++++++++++++++
Sub fin_Please(Rg1 As Range)
   D1 = Application.Min(Rg1.Resize(, 2))
   D2 = Application.Max(Rg1.Resize(, 2))
    For K = 2 To L_M
        x = IsDate(M.Cells(K, 1))
        y = M.Cells(K, 1) >= D1
        z = M.Cells(K, 1) <= D2
          If x * y * z <> 0 Then
            Obj(M.Cells(K, 3).Value) = vbNullString
          End If
    Next K
If Obj.Count Then
 Rem Typing The Results in the Sheet
     xx = F.Cells(Rows.Count, 1).End(3).Row + 1
     With F.Range("A" & xx)
      .Value = "From " & F.Range("D" & A) _
              & " To " & F.Range("E" & A)
      .Interior.ColorIndex = 40
          With .Offset(1).Resize(Obj.Count)
           .Value = Application.Transpose(Obj.keys)
           .Interior.ColorIndex = 35
           .Offset(, 1).Value = _
            Evaluate("Row(1:" & Obj.Count & ")")
            .Offset(, 1).Interior.ColorIndex = 19
           End With
     End With
 Rem End Of Typing The Results in the Sheet
End If

End Sub
'+++++++++++++++++++++++++++++++++++++++
Sub test()
      Rem Created By Salim Hasbaya On Nov. 17 2020
Application.ScreenUpdating = False
    Dim First_Col, Second_col%, Mycol%
    Dim Cel As Range, Mesg$
    
    Set F = Sheets("Final")
    Set M = Sheets("Main")
    Set Obj = CreateObject("Scripting.Dictionary")
 Rem Clear Old Data
    t = F.Range("A2").CurrentRegion.Rows.Count
    If t > 1 Then
      F.Range("A2").CurrentRegion. _
        Offset(1).Resize(t - 1).Clear
     End If
 Rem End of Clear Old Data
    L_F = F.Cells(Rows.Count, 4).End(3).Row
    L_M = M.Cells(Rows.Count, 1).End(3).Row
 Rem For Control the dates====================
    First_Col = L_F
    Second_col = F.Cells(Rows.Count, 5).End(3).Row
    If First_Col < 2 Or Second_col < 2 Then
      Application.ScreenUpdating = True
      Exit Sub
    End If
    Mycol = Application.Max(First_Col, Second_col)
        For Each Cel In F.Range("D2:E" & Mycol)
          If Not IsDate(Cel) Then
           Mesg = Mesg & Cel.Address & Chr(10)
          End If
         Next
      If Mesg <> "" Then
        MsgBox "Check Up This Cells Please:" & Chr(10) _
         & Mesg & Chr(10) & _
         "They Must Be A Date"
         Application.ScreenUpdating = True
        Exit Sub
       End If
 Rem End of For Control the dates ==================

Rem Looping Throught the dates in Column D And E
    For A = 2 To L_F
     fin_Please (Sheets("Final").Range("D" & A))
     Obj.RemoveAll
    Next
Rem end of Looping Throught the dates in Column D And E

Rem Format The Results
    t = F.Range("A2").CurrentRegion.Rows.Count
    If t > 1 Then
        With F.Range("A2").CurrentRegion. _
          Offset(1).Resize(t - 1).SpecialCells(2, 23)
          .Borders.LineStyle = 1
          .InsertIndent 1
          .Font.Size = 16: .Font.Bold = True
        End With
    End If
Rem End Of Format The Results
Application.ScreenUpdating = True
End Sub

الملف من جديد

Hani_Exact_1.xlsm