مطلوب معادلة تجمع الاسماء

[سيف الدين ابو باسم]

السلام عليكم ورحمة الله وبركاته اساتذتى الكرام الزين لايبخلون علينا بشىء وربنا يبارك فيهم اجمعين .

المطلوب تجميع الاسماء الزين فى جدول ( أ ) داخل جدول ( ب ) بالترتيب اومن غير ترتيب عادى اقول الحمد لله انه يكون فى اهتماممن حضراتكم  ولسيادكم جذيل الشكر .

الى حضراتكم المرفق

تجميع بالترتيب.rar

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

وعليكم السلام

Sub Test()
    Dim arr As Variant
    Dim temp As Variant
    Dim i As Long
    Dim r As Long
    
    arr = Range("B3:C36").Value
    ReDim temp(1 To UBound(arr, 1), 1 To 2)
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not IsEmpty(arr(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr(i, 1)
            temp(r, 2) = arr(i, 2)
        End If
    Next i
    
    Range("G3").Resize(r, 2).Value = temp
End Sub

 

[سيف الدين ابو باسم]

استاذ ياسر ماشاءالله عليك زى ماانا طلبط بالظبط ووضعت الكود وبقى تمام بس انا لقيت انه لو فى جدول اكبر وتم وضعه على جزئين ممكن حضرتك تعدلى فى الكود والى حضرتك شكل الجدول لما يكبر

تجميع اسماء.rar

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

Sub Test()
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim temp As Variant
    Dim i As Long
    Dim r As Long
    
    arr1 = Range("B3:C36").Value
    arr2 = Range("E3:F36").Value
    
    ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2)
    
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        If Not IsEmpty(arr1(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr1(i, 1)
            temp(r, 2) = arr1(i, 2)
        End If
    Next i
    
    For i = LBound(arr2, 1) To UBound(arr2, 1)
        If Not IsEmpty(arr2(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr2(i, 1)
            temp(r, 2) = arr2(i, 2)
        End If
    Next i
    
    
    Range("J3").Resize(r, 2).Value = temp
End Sub

 

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

بعد إذن أخي ياسر

نفس الشيء لكن بالمعادلات

 

تجميع بالترتيب Salim.rar

[سيف الدين ابو باسم]

استاذ ياسر واستاذ سليم انا بشكر حضرتكم على الاهتمام  وبارك الله فيكم بس في توضيح للكود الخاص بالاستاذ ياسر انه لما الاسماء بتزيد فى الجدول ( أ ) بتنزل عن حد الجدول ( ب ) يعنى مش بتلف مع تسلسل الجدول والى حضرتك المرفق بعد وضع الكود والخروج عن الجدول .

 

2تجميع اسماء.rar

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

Sub Test()
    Dim arr1        As Variant
    Dim arr2        As Variant
    Dim temp        As Variant
    Dim varTemp1    As Variant
    Dim varTemp2    As Variant
    Dim i           As Long
    Dim r           As Long
    Dim x           As Long

    arr1 = Range("B3:C36").Value
    arr2 = Range("E3:F36").Value

    ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2)

    For i = LBound(arr1, 1) To UBound(arr1, 1)
        If Not IsEmpty(arr1(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr1(i, 1)
            temp(r, 2) = arr1(i, 2)
        End If
    Next i

    For i = LBound(arr2, 1) To UBound(arr2, 1)
        If Not IsEmpty(arr2(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr2(i, 1)
            temp(r, 2) = arr2(i, 2)
        End If
    Next i

    If r > 34 Then
        ReDim varTemp1(1 To 34, 1 To 2)
        For i = 1 To 34
            varTemp1(i, 1) = temp(i, 1)
            varTemp1(i, 2) = temp(i, 2)
        Next i
        Range("J3").Resize(34, 2).Value = varTemp1

        ReDim varTemp2(35 To UBound(temp, 1), 1 To 2)
        For i = 35 To UBound(temp, 1)
            varTemp2(i, 1) = temp(i, 1)
            varTemp2(i, 2) = temp(i, 2)
        Next i
        Range("M3").Resize(r - 34, 2).Value = varTemp2
    Else
        Range("J3").Resize(r, 2).Value = temp
    End If
End Sub

 

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

19 دقائق مضت, ياسر خليل أبو البراء said:

Sub Test()
    Dim arr1        As Variant
    Dim arr2        As Variant
    Dim temp        As Variant
    Dim varTemp1    As Variant
    Dim varTemp2    As Variant
    Dim i           As Long
    Dim r           As Long
    Dim x           As Long

    arr1 = Range("B3:C36").Value
    arr2 = Range("E3:F36").Value

    ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2)

    For i = LBound(arr1, 1) To UBound(arr1, 1)
        If Not IsEmpty(arr1(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr1(i, 1)
            temp(r, 2) = arr1(i, 2)
        End If
    Next i

    For i = LBound(arr2, 1) To UBound(arr2, 1)
        If Not IsEmpty(arr2(i, 1)) Then
            r = r + 1
            temp(r, 1) = arr2(i, 1)
            temp(r, 2) = arr2(i, 2)
        End If
    Next i

    If r > 34 Then
        ReDim varTemp1(1 To 34, 1 To 2)
        For i = 1 To 34
            varTemp1(i, 1) = temp(i, 1)
            varTemp1(i, 2) = temp(i, 2)
        Next i
        Range("J3").Resize(34, 2).Value = varTemp1

        ReDim varTemp2(35 To UBound(temp, 1), 1 To 2)
        For i = 35 To UBound(temp, 1)
            varTemp2(i, 1) = temp(i, 1)
            varTemp2(i, 2) = temp(i, 2)
        Next i
        Range("M3").Resize(r - 34, 2).Value = varTemp2
    Else
        Range("J3").Resize(r, 2).Value = temp
    End If
End Sub

 

بعد إذن أخي ياسر

نفس الشيء لكن بالمعادلات

صباح الخير أخي ياسر

انا لا ارى ان هناك لزوماً للمصفوفات

يكفي هذا الكود

Sub Tajmi3()
lr = Application.Max(Range("a:a")) + 2
Range("b3:b" & lr).SpecialCells(xlCellTypeConstants).Copy Range("j3")
Range("c3:c" & lr).SpecialCells(xlCellTypeConstants).Copy Range("k3")
Range("e3:e" & lr).SpecialCells(xlCellTypeConstants).Copy Range("m3")
Range("f3:f" & lr).SpecialCells(xlCellTypeConstants).Copy Range("n3")

End Sub

 

 

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

لاحظ في الملف المرفق الأخير عدم وجود مبالغ مع بعض الأسماء

[سيف الدين ابو باسم]

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

 

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

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

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

[سيف الدين ابو باسم]

السلام عليكم ورحمة الله وبركاته يااستاذ ياسر الكود الخاص بحضرتك زى ماقولت سليم 100% بس انا لما جيت اوضعه داخل الملف الاصلى الخاص بعملى مش عايز يظبط معايا ممكن لو تكرمت تساعدنى فى وضعه ولسيادتكم جزيل الشكر والتقدير والى حضرتك الملف الاصلى .

تجربة استقطاعات.rar

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

وعليكم السلام

Sub Test()
    Dim arr1        As Variant
    Dim arr2        As Variant
    Dim temp        As Variant
    Dim varTemp1    As Variant
    Dim varTemp2    As Variant
    Dim i           As Long
    Dim r           As Long
    Dim x           As Long

    arr1 = Range("B55:F234").Value
    arr2 = Range("H55:L234").Value

    ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 5)

    For i = LBound(arr1, 1) To UBound(arr1, 1)
        If Not IsEmpty(arr1(i, 2)) Then
            r = r + 1
            temp(r, 1) = arr1(i, 1)
            temp(r, 2) = arr1(i, 2)
            temp(r, 5) = arr1(i, 5)
        End If
    Next i

    For i = LBound(arr2, 1) To UBound(arr2, 1)
        If Not IsEmpty(arr2(i, 2)) Then
            r = r + 1
            temp(r, 1) = arr2(i, 1)
            temp(r, 2) = arr2(i, 2)
            temp(r, 5) = arr2(i, 5)
        End If
    Next i

    If r > 180 Then
        ReDim varTemp1(1 To 180, 1 To 5)
        For i = 1 To 34
            varTemp1(i, 1) = temp(i, 1)
            varTemp1(i, 2) = temp(i, 2)
            varTemp1(i, 5) = temp(i, 5)
        Next i
        Range("O55").Resize(180, 5).Value = varTemp1

        ReDim varTemp2(181 To UBound(temp, 1), 1 To 5)
        For i = 181 To UBound(temp, 1)
            varTemp2(i, 1) = temp(i, 1)
            varTemp2(i, 2) = temp(i, 2)
            varTemp2(i, 5) = temp(i, 5)
        Next i
        Range("U55").Resize(r - 180, 5).Value = varTemp2
    Else
        Range("O55").Resize(r, 5).Value = temp
    End If
End Sub

 

[سيف الدين ابو باسم]

بارك الله فيك يااستاذ ياسر وهو المطلوب فعلا وجعلك الله دائما فى عون المحتاجين ومساعدتك لنا دائما وانا شاكر تقدير سيادتكم .

[سيف الدين ابو باسم]

السلام عليكم يااستاذ ياسر انا وضعت الكود وتمام زيل الفل بارك الله فيك بس فيه عيب الجدول الاول يوجد به معادلة vlookup والكود بيشوفها على انها اسم داخل الخليه مع ان الخليه فاضيه برجاء خليه يتجاهل المعادلات ولا يتعامل معها على انها شيئ داخل الخليه انا عارف ان حضرتك تعبت معى برجاء النظر .

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

وعليكم السلام

لم أفهم المشكلة بشكل واضح ..ارفق ملف معبر عن الملف الأصلي

[سيف الدين ابو باسم]

السلام عليكم يااستاذ ياسر انا وضعت الى حضرتك ملف معبر عن الاصل ووضعت به الكود وحضرتك سوف تلاحظ الناتج .

تجربة مرتب.rar

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

وعليكم السلام

يوجد سطرين بالكود بهذا الشكل

If Not IsEmpty(arr1(i, 2)) Then

قم باستبدالهما بهذا الشكل

If arr1(i, 2) <>"" Then

انتبه بالنسبة للسطر الثاني ستستخدم كلمة arr2 وليس arr1 ...

[سيف الدين ابو باسم]

السلام عليكم يااستاذ ياسر انا فعلا عاجز عن الشكر والحمدلله كله بقى تمام بفضل ربنا سبحانه وتعالى وحضرتك وبارك الله فيك وجعلك الله دائما فى عون المحتاجين .

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

وعليكم السلام

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

ولي نصيحة أخيرة : حاول عندما تطرح موضوع أن يكون الملف معبر عن الملف الأصلي تماماً لأن كل ملف وله طبيعته وعمله الخاص والبرمجة تستهدف الهيكلة الموجودة ، فكلما كانت المعطيات دقيقة كانت النتائج صحيحة ودقيقة

تقبل وافر تقديري واحترامي

[سيف الدين ابو باسم]

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