تطابق اسماء الاصناف مع الاصناف المقابلة الغير مرتبة ودمج الكمية اليها

[mahmoud nasr alhasany]

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

الرجاء مساعدتى فى التعديل على هذا الكود

طريقة عمل الكود هو ان الهدف الرئيس ينقل وتنسيق البيانات (Data Transformation): يقوم الكود بالبحث عن قيم مطابقة في عمود (W4:W117) ورؤوس أعمدة مطابقة في صف (Y3:AM3)، واستخراج القيم المتقاطعة من جدول مصدر آخر (D4:U...) ولصق النتائج كقيم ثابتة في النطاق (Y4:AM...).التقنية الأساسيةالعمل بالمصفوفات (Arrays): يتم تحميل جميع البيانات (المصدر، قيم البحث، ورؤوس الأعمدة) إلى الذاكرة. تتم عمليات البحث والمعالجة داخل المصفوفات، ويتم لصق النتائج مرة واحدة فقط في نهاية الكود، مما يزيد السرعة بشكل كبير ويقلل من تفاعلات Excel البطيئة.التنظيف والمعالجةيتضمن الكود وظيفة مسبقة لمسح نطاق النتائج القديم (ClearDataRange)، كما يقوم بـ تنظيف النصوص (إزالة المسافات الزائدة وغير القابلة للكسر) لضمان دقة المطابقة، ويتجاهل القيم الصفرية والفارغة عند اللصق.ورقة العمل يستهدف ورقة عمل محددة باسم "الرصيد 3".

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

 

الكود :-

 

Sub Alternative_CalculateAndPasteValues2()
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("الرصيد 3") ' غيّر 
    
    Dim sourceData As Variant
    Dim lookupValues As Variant
    Dim colHeaders As Variant
    Dim resultArray As Variant
    
    Dim i As Long, j As Long, k As Long
    Dim foundRow As Long, foundCol As Long
    
  Call ClearDataRange
    
    ' Load all data into arrays for speed
    sourceData = ws.Range("D4:U" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row).Value
    lookupValues = ws.Range("W4:W117").Value
    colHeaders = ws.Range("Y3:AM3").Value
    
    ' Resize the result array
    ReDim resultArray(1 To UBound(lookupValues, 1), 1 To UBound(colHeaders, 2))
 
    ' Loop through the lookup values
    For i = 1 To UBound(lookupValues, 1)
        Dim currentLookupValue As String
        currentLookupValue = Trim(Replace(lookupValues(i, 1), Chr(160), " "))
        
        ' Manual loop to find the matching row
        foundRow = 0
        For k = 1 To UBound(sourceData, 1)
            Dim cleanedSourceValue As String
            cleanedSourceValue = Trim(Replace(sourceData(k, 1), Chr(160), " "))
            If StrComp(cleanedSourceValue, currentLookupValue, vbTextCompare) = 0 Then
                foundRow = k
                Exit For
            End If
        Next k
        
        ' If a matching row is found
        If foundRow > 0 Then
            ' Loop through the columns
            For j = 1 To UBound(colHeaders, 2)
                Dim currentHeader As String
                currentHeader = Trim(Replace(colHeaders(1, j), Chr(160), " "))
                
                ' Manual loop to find the matching column (on the G:U headers)
                foundCol = 0
                Dim m As Long
                For m = 1 To 15 ' G to U is 15 columns
                    Dim cleanedHeader As String
                    cleanedHeader = Trim(Replace(ws.Cells(3, m + 6).Value, Chr(160), " "))
                    If StrComp(cleanedHeader, currentHeader, vbTextCompare) = 0 Then
                        foundCol = m
                        Exit For
                    End If
                Next m
                
                ' If a matching column is found
                If foundCol > 0 Then
                    Dim resultValue As Variant
                    resultValue = sourceData(foundRow, foundCol + 3) ' +3 to correct for D-G offset
                    
                    ' Place the result in the array, handling zeros and blanks
                    If IsNumeric(resultValue) And CDbl(resultValue) <> 0 Then
                        resultArray(i, j) = resultValue
                    Else
                        resultArray(i, j) = ""
                    End If
                End If
            Next j
        End If
    Next i
    
    ' Paste the final array to the worksheet in one go
    ws.Range("Y4").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray
    
End Sub

Sub ClearDataRange()
    ' Clears the contents (data) from the range A4:AM125
    Range("Y4:AM125").ClearContents
End Sub

تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm

تم تعديل أكتوبر 27 بواسطه Foksh
ترتيب المشاركة ( الكود يوضع عادة بعد الشرح والتوضيح )

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

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

المشكلة الرئيسية  هي في منطق البحث

 

البحث عن الأعمدة يتم من الصف 3 (G3:U3) ولكن البيانات تبدأ من الصف 4

الإزاحة (offset) غير صحيحة عند استخراج القيم

اليك التعديل

تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm

 

[mahmoud nasr alhasany]

الف شكر استاذنا / عبدالله بشير عبدالله 

عندك حق لقد نسيت اضافة البحث فى العمود (G3:U3)