وعليكم السلام أخي الكريم
ممكن تفاصيل أكتر عن المشكلة ..

اخى الافضل
ياسر
مشكورا على الاهتمام
اريد كود يقوم باستخراج البيانات بطريقه معينه
ارجو النظر الى المرفق

أهلاً بك أخي العزيز إبراهيم
هل تقصد استخراج بيانات بناءً على تاريخ محدد فقط؟ أم أنك تريد ترتيب البيانات ؟
اطلعت على المرفق ولم أفهم الكثير من التفاصيل ..

اخي الفاضل ياسر
مشكورا علي الاهتام

العمود الثالث به ارقام
الارقام تتكرر

يعني مثلا العمود الثالث به الارقام من 1 ال 3
اريد استخراج الييانات التي تخص الرقم 1
في تاريخ معين مثلا 1-5 التاريخ ده موجود ف العمود الاول

ثم استخراج الييانات التي تخص الرقم 2
في نفس التاريخ 1-5 
ثم استخراج الييانات التي تخص الرقم 3
في نفس التاريخ 1-5

وهكذا

مع ترك سطور فارغه بي كل عمليه استخراج

الارقام ف العمود الثالث ليس ثابته
يعني ممكن تكون 1 و 2 و3 و5 و6 وهكذا

لذلك اريد ف الكود ان اتحكم ف ادخال الارقام من الي
علي حسب ما اريد

اتمني ان اكون استطعت توصيل المطلوب

تقبل تحياتي 

المشاركة الأصلية كتبت بواسطة: EM_ACC بتاريخ: 26-05-2023 02:55 مساءًلمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريبالارقام ف العمود الثالث ليس ثابته
يعني ممكن تكون 1 و 2 و3 و5 و6 وهكذا

لذلك اريد ف الكود ان اتحكم ف ادخال الارقام من الي
علي حسب ما اريد

ممكن توضيح للنقطة دي؟؟

بمعني ان العمود ده بتكتب فيه الارقام
من 1 الي 10
فممكن وقت الاستخراج
يكون العمود مفهوش غير الرقم
1 بس
وممكن يكون فيه الرقم 1 و3
او 2 و3

بمعنى 
ان انا وقت الاستخراج
الكود هيكون عامل زي حلقه تكراريه
هيدور علي الارقام من 1 ال 5
وده هيبقا انا ال محددله الارقام
دى عن طريق كتابتها فى خلايا معينه بالشيت
او فى فورم
ال يلاقيها يستخرج بياناتها مع شرط التاريخ

بشكل مبدئي ويمكنك استكمال الأمر حيث أن وقتي لا يتسع للكود بالكامل
ضع أرقام المجموعات التي تريدها في العمود H ثم نفذ الكود التالي

Sub Test()
    Dim v, x, rng As Range, lr As Long, r As Long, m As Long
    Application.ScreenUpdating = False
        With Sheet1
            .Columns("J:M").ClearContents
            v = .Range("A1").Value
            Set rng = .Range("H1:H" & .Cells(Rows.Count, "H").End(xlUp).Row)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            m = 1
            For r = 3 To lr
                If .Cells(r, 1).Value = v Then
                    x = Application.Match(.Cells(r, 3).Value, rng, 0)
                    If Not IsError(x) Then
                        .Range("J" & m).Resize(, 4).Value = .Cells(r, 1).Resize(, 4).Value
                        m = m + 1
                    End If
                End If
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

سيقوم الكود باستخراج البيانات حسب التاريخ الموضوع في الخلية A1 وبناءً على الأرقام التي وضعتها في العمود H ، ويتم وضع النتائج في نفس الورقة في الأعمدة J إلى M

يمكنك بعد ذلك عمل ترتيب Sort حسب العمود الثالث في النتائج بحيث تحصل على المجموعات بشكل متتالي

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

Sub Test()
T = Timer
    Dim v, x, rng As Range, lr As Long, r As Long, m As Long
    Application.ScreenUpdating = False
        With Sheet1
            .Columns("J:M").ClearContents
            v = .Range("A1").Value
            Set rng = .Range("H1:H" & .Cells(Rows.Count, "H").End(xlUp).Row)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
       
            m = 1                      
For h = 1 To 3
            For r = 3 To lr                  
              If .Cells(r, 1).Value = v Then       
            If .Cells(r, 3).Value = h Then
                  .Range("J" & m).Resize(, 4).Value = .Cells(r, 1).Resize(, 4).Value
                        m = m + 1
'' x = Application.Match(.Cells(r, 3).Value, rng, 0)
                  'If Not IsError(x) Then
                  ' End If
              End If
            End If
            Next
          
            Next
        End With
    Application.ScreenUpdating = True
  MsgBox Timer - T

جرب الكود بهذا الشكل

Sub Test()
    Dim v, rng As Range, t As Double, h As Long, lr As Long, r As Long, m As Long
    t = Timer
    Application.ScreenUpdating = False
        With Sheet1
            .Columns("J:M").ClearContents
            v = .Range("A1").Value
            Set rng = .Range("H1:H" & .Cells(Rows.Count, "H").End(xlUp).Row)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            m = 1
            For h = 1 To 3
                For r = 3 To lr
                    If .Cells(r, 1).Value = v Then
                        If .Cells(r, 3).Value = h Then
                            .Range("J" & m).Resize(, 4).Value = .Cells(r, 1).Resize(, 4).Value
                            m = m + 1
                        End If
                    End If
                Next r
            Next h
            For r = 2 To m
                If .Cells(r, "L").Value <> .Cells(r + 1, "L").Value Then
                    .Cells(r + 1, "J").Resize(, 4).Insert Shift:=xlDown
                    r = r + 2
                End If
            Next r
        End With
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

اخى الفاضل
ياسر
مشكورا على الكود الجميل ده
بارك الل فيك
تقبل تحياتى

بارك الله فيك أخي العزيز إبراهيم ومشكور على كلماتك الطيبة