مشكله غريبه حدااا مش لاقى ليها حل

[اركان الاسلام]

عتدى شيت الصقخه الاولى للخامات المقدره والصفحه التانيه للمنصرف الفعلى والصفحه الثالثه  لعمل تقرير ومقارنه  

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

Sub مقارنة_المشاريع()
    Dim wsArchive As Worksheet, wsIssue As Worksheet, wsReport As Worksheet
    Dim lastRowArchive As Long, lastRowIssue As Long, lastRowReport As Long
    Dim i As Long, j As Long, nextRow As Long
    Dim client As String, itemCode As String, itemName As String
    Dim materialCode As String, materialName As String
    Dim dictProjects As Object, key As Variant
    Dim estimatedQty As Double, estimatedPrice As Double
    Dim issuedQty As Double, issuedPrice As Double
    Dim totalEst As Double, totalIss As Double

    Set wsArchive = ThisWorkbook.Sheets("الارشيف")
    Set wsIssue = ThisWorkbook.Sheets("اذون الصرف")
    Set wsReport = ThisWorkbook.Sheets("التقرير النهائى")
    wsReport.Cells.Clear
    Set dictProjects = CreateObject("Scripting.Dictionary")
   
    lastRowArchive = wsArchive.Cells(wsArchive.Rows.Count, "M").End(xlUp).Row
    lastRowIssue = wsIssue.Cells(wsIssue.Rows.Count, "A").End(xlUp).Row
   
    ' إنشاء قائمة المشاريع من صفحة الارشيف
    For i = 4 To lastRowArchive
        client = wsArchive.Cells(i, "M").Value
        itemCode = wsArchive.Cells(i, "N").Value
        itemName = wsArchive.Cells(i, "O").Value
        key = client & "|" & itemCode & "|" & itemName
        If Not dictProjects.exists(key) Then
            dictProjects.Add key, key
        End If
    Next i
   
    ' كتابة الجدول الرئيسي لكل المشاريع
    wsReport.Range("C5").Value = "اسم العميل"
    wsReport.Range("D5").Value = "كود الايتم"
    wsReport.Range("E5").Value = "اسم الايتم"
   
    With wsReport.Range("C5:E5")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 204)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With
   
    nextRow = 6
    For Each key In dictProjects.Keys
        Dim parts() As String
        parts = Split(key, "|")
        wsReport.Cells(nextRow, 3).Value = parts(0)
        wsReport.Cells(nextRow, 4).Value = parts(1)
        wsReport.Cells(nextRow, 5).Value = parts(2)
        nextRow = nextRow + 1
    Next key
   
    nextRow = nextRow + 2
   
    ' لكل مشروع نكتب جدول تفصيلي
    For Each key In dictProjects.Keys
        parts = Split(key, "|")
        client = parts(0)
        itemCode = parts(1)
        itemName = parts(2)
       
        ' عناوين الجدول
        wsReport.Cells(nextRow, 3).Resize(1, 12).Value = Array("اسم العميل", "كود الايتم", "اسم الايتم", "كود الخامه", "اسم الخامه", "كمية مقدرة", "سعر", "إجمالي مقدر", "كمية منصرفة", "سعر منصرف", "إجمالي منصرف")
        With wsReport.Range(wsReport.Cells(nextRow, 3), wsReport.Cells(nextRow, 14))
            .Font.Bold = True
            .Interior.Color = RGB(204, 255, 255)
            .HorizontalAlignment = xlCenter
        End With
        nextRow = nextRow + 1
       
        ' نبدأ بجمع المواد من صفحة الارشيف
        For i = 4 To lastRowArchive
            If wsArchive.Cells(i, "M").Value = client And wsArchive.Cells(i, "N").Value = itemCode Then
                materialCode = wsArchive.Cells(i, "P").Value
                materialName = wsArchive.Cells(i, "Q").Value
               
                ' التحقق من القيم قبل إضافتها
                If IsNumeric(wsArchive.Cells(i, "R").Value) Then
                    estimatedQty = wsArchive.Cells(i, "R").Value
                Else
                    estimatedQty = 0
                End If
               
                If IsNumeric(wsArchive.Cells(i, "S").Value) Then
                    estimatedPrice = wsArchive.Cells(i, "S").Value
                Else
                    estimatedPrice = 0
                End If
               
                ' نبحث في اذون الصرف عن نفس المادة
                issuedQty = 0
                issuedPrice = 0
                For j = 2 To lastRowIssue
                    If wsIssue.Cells(j, "B").Value = client And wsIssue.Cells(j, "C").Value = itemCode And wsIssue.Cells(j, "E").Value = materialCode Then
                        If IsNumeric(wsIssue.Cells(j, "G").Value) Then
                            issuedQty = issuedQty + wsIssue.Cells(j, "G").Value
                        End If
                        If IsNumeric(wsIssue.Cells(j, "H").Value) Then
                            issuedPrice = wsIssue.Cells(j, "H").Value ' سعر الكمية المنصرفه
                        End If
                    End If
                Next j
               
                ' نكتب البيانات في الجدول
                wsReport.Cells(nextRow, 3).Value = client
                wsReport.Cells(nextRow, 4).Value = itemCode
                wsReport.Cells(nextRow, 5).Value = itemName
                wsReport.Cells(nextRow, 6).Value = materialCode
                wsReport.Cells(nextRow, 7).Value = materialName
                wsReport.Cells(nextRow, 8).Value = estimatedQty
                wsReport.Cells(nextRow, 9).Value = estimatedPrice
                wsReport.Cells(nextRow, 10).Value = estimatedQty * estimatedPrice ' الإجمالي المقدّر
                wsReport.Cells(nextRow, 11).Value = issuedQty
                wsReport.Cells(nextRow, 12).Value = issuedPrice
                wsReport.Cells(nextRow, 13).Value = issuedQty * issuedPrice ' الإجمالي المنصرف
               
                nextRow = nextRow + 1
            End If
        Next i
       
        ' الآن نبحث عن الخامات المنصرفة التي لم تكن ضمن الخامات المقدرة
        For i = 2 To lastRowIssue
            If wsIssue.Cells(i, "B").Value = client And wsIssue.Cells(i, "C").Value = itemCode Then
                materialCode = wsIssue.Cells(i, "E").Value
                materialName = wsIssue.Cells(i, "F").Value
               
                ' تحقق مما إذا كانت هذه المادة قد تم إضافتها بالفعل ضمن الخامات المقدرة
                Dim found As Boolean
                found = False
                For j = 4 To lastRowArchive
                    If wsArchive.Cells(j, "M").Value = client And wsArchive.Cells(j, "N").Value = itemCode And wsArchive.Cells(j, "P").Value = materialCode Then
                        found = True
                        Exit For
                    End If
                Next j
               
                ' إذا كانت الخامة غير موجودة ضمن المقدرة، نضيفها
                If Not found Then
                    issuedQty = 0
                    issuedPrice = 0
                    If IsNumeric(wsIssue.Cells(i, "G").Value) Then
                        issuedQty = wsIssue.Cells(i, "G").Value
                    End If
                    If IsNumeric(wsIssue.Cells(i, "H").Value) Then
                        issuedPrice = wsIssue.Cells(i, "H").Value
                    End If
                   
                    ' نكتب البيانات في الجدول
                    wsReport.Cells(nextRow, 3).Value = client
                    wsReport.Cells(nextRow, 4).Value = itemCode
                    wsReport.Cells(nextRow, 5).Value = itemName
                    wsReport.Cells(nextRow, 6).Value = materialCode
                    wsReport.Cells(nextRow, 7).Value = materialName
                    wsReport.Cells(nextRow, 8).Value = 0 ' لا يوجد كمية مقدرة
                    wsReport.Cells(nextRow, 9).Value = 0 ' لا يوجد سعر مقدر
                    wsReport.Cells(nextRow, 10).Value = 0 ' إجمالي مقدر = 0
                    wsReport.Cells(nextRow, 11).Value = issuedQty
                    wsReport.Cells(nextRow, 12).Value = issuedPrice
                    wsReport.Cells(nextRow, 13).Value = issuedQty * issuedPrice ' الإجمالي المنصرف
                   
                    nextRow = nextRow + 1
                End If
            End If
        Next i
       
        ' صفين فاصلين
        nextRow = nextRow + 2
    Next key
   
    wsReport.Columns("C:N").AutoFit
    MsgBox "تم إنشاء التقرير المقارن لكل المشاريع."
End Sub

 

 

 

 

New Microsoft Excel Worksheet.xlsx

 

ردإعادة توجيه   إضافة تفاعل

[عبدالله بشير عبدالله]

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

حسب فهمي لمشكلة  عدم الحفظ

السبب ان 

امنداد ملفك xlsx  (المقصود بالامتداد يكون بعد اسم الملف)

هذا النوع من الامتداد لا تحتفظ بالأكواد (مثل أكواد VBA) لأنها مصممة فقط لتخزين البيانات والصيغ والرسومات — ولكن دون دعم للماكرو أو الأكواد البرمجية.

انواع الامتداد التي تحتفظ  بالاكواد  xlsm  -   xlsb  

او  xls لاصدار 2003 او اقل

 قم بوضع الكود في ملقك ثم  اختر ملف ثم حفظ باسم واختار  اما xlsm  او xlsb  

ثم احفظ الملف  على سطح المكتب مثلا 

قم بفتح الملف الجديد الذي قمت بحفظه وليس الاول ستجد الكود بداخله 

اليك مثال لاحظ الامتداد 

New Microsoft Excel Worksheet.xlsb

هذا حسب فهمي لطلبك وان كان ما دكرته ليس المطلوب فاوضح اكثر

 

 

[اركان الاسلام]

استاذى الفاضل انا لو وضعت الكود داخل الشيت اول ما اخلص شغل واخفظ هيتمسح 

ولذلك انا رفعت شيت الاكسيل لوحده والكود لحده  

يارب اكون قدرت اوصل الفكره او المشكله