نجوم المشاركات

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

السلام عليكم اخي سعد عابد حسب فهمي لطلبك جرب هذا الكود Dim Sh As Worksheet Public Sub Ali_T() Dim S As Worksheet Dim Rn As Range Dim R Set S = Sheets("مشتريات") Set Sh = Sheets("RR") Rw = 6 L_r = S.Cells(Rows.Count, 2).End(xlUp).Row Set Rn = S.Range(S.Cells(5, 1), S.Cells(L_r, 10)) With Application .ScreenUpdating = False .EnableEvents = False With Rn For R = 1 To .Rows.Count If .Cells(R, 1).Value >= S.[J1] And .Cells(R, 1).Value <= S.[K1] Then If .Cells(R, 6) = S.[F2] Then S.Range(.Cells(R, 2), .Cells(R, 9)).Copy Sh.Cells(Rw, 2).PasteSpecial xlPasteValues Rw = Rw + 1 End If End If Next End With .CutCopyMode = False .EnableEvents = True .ScreenUpdating = True End With If WorksheetFunction.CountA(Sh.Range("B6:B10")) >= 2 Then Ali_Ds End Sub Private Sub Ali_Ds() Dim Rn, L_Rn As Range Dim A_di As Object Dim A_Sum(), V_Rn() Dim A_i As Long, E, Dc, L_r, L_rr As Long Set Sh = Sheets("RR") With Application .ScreenUpdating = False .EnableEvents = False Sh.Activate .ScreenUpdating = False L_r = Sh.Cells(.Rows.Count, "B").End(xlUp).Row + 1 Set Rn = Sh.Range("B6:I" & L_r) Rn.Select V_Rn = Rn.Value ReDim A_Sum(1 To UBound(V_Rn, 1), 1 To 8) Set A_di = CreateObject("Scripting.Dictionary") With A_di For A_i = 1 To UBound(V_Rn, 1) If Not .exists(V_Rn(A_i, 1)) Then E = E + 1 For Dc = 1 To 8 A_Sum(E, Dc) = V_Rn(A_i, Dc) Next Dc .Add V_Rn(A_i, 1), E ElseIf .exists(V_Rn(A_i, 1)) Then A_Sum(.Item(V_Rn(A_i, 1)), 7) = A_Sum(.Item(V_Rn(A_i, 1)), 7) + V_Rn(A_i, 7) End If Next A_i End With L_rr = ActiveSheet.UsedRange.Rows.Count Set L_Rn = Range("B6:I" & L_rr) L_Rn.Clear Sh.Range("B6").Resize(E, 8).Value = A_Sum .EnableEvents = True .ScreenUpdating = True End With End Sub فاتورة_A.rar