عمل كود لجمع الفواتير عمل كود لجمع الفواتير

[على حسن]

New Microsoft Excel Worksheet.rar

[خالد الرشيدى]

اخى الفاضل

جرب المرفق لعلة المطلوب

 New Microsoft Excel Worksheet_2.rar

[على حسن]

استاذ خالد الرشيدى 

اشكرك على سرعة الرد لكننى لاسف لم افهم  اجابتك

فانا اريد عمل كود يقوم بالجدول الثانى تلقائيا

 

 

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

الأخ الكريم علي حسن

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

إليك الملف التالي عله يكون المطلوب ..تم العمل على ورقة العمل  Sheet2 قم بالضغط على زر الأمر لتنفيذ الكود

Sub RunTest()
    Dim LR As Long, Rng As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With Sheets("Sheet2")
            LR = .Cells(Rows.Count, 1).End(xlUp).Row
            Set Rng = .Range("A1:C" & LR)
            .Columns("F").ColumnWidth = .Columns("A").ColumnWidth
            .Columns("G").ColumnWidth = .Columns("B").ColumnWidth
            .Columns("H").ColumnWidth = .Columns("C").ColumnWidth
            Sheets.Add After:=Sheets(Sheets.Count)
            Rng.Copy ActiveSheet.Range("A1")
        End With
    
        With ActiveSheet.Range("D2:D" & LR)
            .Formula = "=SUMPRODUCT(($A$2:$A$" & LR & "=A2)*($B$2:$B$" & LR & "=B2)*($C$2:$C$" & LR & "))": .Value = .Value
            .Offset(0, -1).Value = .Value
        End With
        
        With ActiveSheet
            .Range("A1:C" & LR).RemoveDuplicates Columns:=VBA.Array(1, 2, 3), Header:=xlYes
            .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Sheet2").Range("F1")
            .Delete
        End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

أرجو أن يكون المطلوب

Remove Duplicates For Summary Report.rar

تم تعديل أغسطس 9, 2015 بواسطه ياسر خليل أبو البراء

[على حسن]

استاذ ياسر خليل أبو البراء

شكرا جزيلا لاهتمامك

واعتذر عن طريقة عرضى للسؤال فللاسف لى فتره لم اتواصل معكم

استاذى العزيز ياسر خليل أبو البراء

لى تعديل بعد اذن حضرتك  

هل استطيع ان اجعل الكود يعمل لجميع الشيتات

Remove Duplicates For Summary Report.rar

تم تعديل أغسطس 9, 2015 بواسطه على حسن

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

لم أفهم المطلوب وضح بشيء من التفصيل ..كيف تريد شكل النتائج ؟؟ من ورقتي العمل ؟؟

[على حسن]

اسف ارفق لحضرتك ورقة عمل خاطئه

Remove Duplicates For Summary Report.rar

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

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

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

قم بالإطلاع على المرفق التالي لعله يكون المطلوب

Sub RunTest()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR_WS As Long, LR_SH As Long, Rng As Range
    Set SH = Sheets("Collect")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
        SH.Range("A2:D1000").ClearContents
        
        For Each WS In ThisWorkbook.Sheets
        
            If WS.Name <> "Collect" Then
            
                LR_SH = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
                With WS
                    LR_WS = .Cells(Rows.Count, 1).End(xlUp).Row
                    Set Rng = .Range("A2:D" & LR_WS)
                    Sheets.Add After:=Sheets(Sheets.Count)
                    Rng.Copy ActiveSheet.Range("A2")
                End With
    
                With ActiveSheet.Range("E2:E" & LR_WS)
                    .Formula = "=SUMPRODUCT(($A$2:$A$" & LR_WS & "=A2)*($B$2:$B$" & LR_WS & "=B2)*($C$2:$C$" & LR_WS & "))": .Value = .Value
                    .Offset(0, -2).Value = .Value
                End With
    
                With ActiveSheet
                    .Range("A2:D" & LR_WS).RemoveDuplicates Columns:=VBA.Array(1, 2, 3), Header:=xlNo
                    .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy: SH.Range("A" & LR_SH).PasteSpecial xlPasteValues
                    .Delete
                End With
                
            End If
            
        Next WS
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

Remove Duplicates For Summary Report YasserKhalil.rar