تصدير البيانات بدون تكرار الاصناف وجمع القيم لكل صنف

[mahmoud nasr alhasany]

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

يوجد مشكلة فى الكود المدرج يبدو ان المشكلة خاصة بتنسيق بعض البيانات لا يتعامل معها وذلك بسبب بعض الاكواد يبدأ  0 او 00 قبل الرقم 

يوجد اصناف معينة بعد تصديرها لايقوم بجمع القيم مثل

00744 و 00743 و 02771 و 02770

اما باقى القيم يعمل جيدا مع الاصناف

 

Sub تصدير_بيانات_و_تجميعها()

  Dim wsSource As Worksheet, wsDest As Worksheet
  Dim lastRow As Long, i As Long, destRow As Long
  Dim itemCode As String, itemName As String, itemUnit As String
  Dim itemPrice As Double, cartnCount As Long
  Dim dict As Object ' Dictionary to store unique items
  Dim key As Variant ' To loop through dictionary keys efficiently

  ' Set the source and destination worksheets
  Set wsSource = ThisWorkbook.Sheets("Sheet3") ' Change "Sheet3" to your source sheet name
  Set wsDest = ThisWorkbook.Sheets("رصيد") ' Change "رصيد" to your destination sheet name

  ' Find the last row in the source sheet (start from row 2 to avoid headers)
  lastRow = wsSource.Cells(Rows.Count, 7).End(xlUp).Row
  If lastRow < 2 Then Exit Sub ' Exit if no data

  ' Create a dictionary to store unique items
  Set dict = CreateObject("Scripting.Dictionary")

  ' Initialize destination row
  destRow = 2 ' Start from row 2 (assuming row 1 is for headers)

  ' Loop through each row in the source sheet
  For i = 2 To lastRow

    ' Get item code and name
    itemCode = Trim(wsSource.Cells(i, 7).Value) ' Trim whitespace
    itemName = Trim(wsSource.Cells(i, 6).Value) ' Trim whitespace
    itemUnit = Trim(wsSource.Cells(i, 4).Value) ' Trim whitespace
    itemPrice = CDbl(wsSource.Cells(i, 5).Value) ' Convert to Double, handle errors later
    cartnCount = CLng(wsSource.Cells(i, 3).Value) ' Convert to Long, handle errors later

    ' Skip rows with empty item codes
    If itemCode = "" Then GoTo NextIteration

    ' Add new item to dictionary or update existing
    If Not dict.Exists(itemCode) Then
      dict.Add itemCode, Array(itemName, itemUnit, itemPrice, cartnCount)
    Else
'      dict(itemCode)(3) = dict(itemCode)(3) + cartnCount
    End If

NextIteration:
  Next i

  ' Write headers to the destination sheet
  With wsDest
    .Cells(1, 1).Value = "كود الصنف"
    .Cells(1, 2).Value = "اسم الصنف"
    .Cells(1, 3).Value = "وحدة الصنف"
    .Cells(1, 4).Value = "سعر الصنف"
    .Cells(1, 5).Value = "عدد الكراتين"

    ' Loop through the dictionary and write data to the destination sheet
    For Each key In dict.Keys ' More efficient way to loop
      With .Cells(destRow, 1)
        .Value = key
        .Offset(0, 1).Value = dict(key)(0) ' itemName
        .Offset(0, 2).Value = dict(key)(1) ' itemUnit
        .Offset(0, 3).Value = dict(key)(2) ' itemPrice
        .Offset(0, 4).Value = dict(key)(3) ' cartnCount
      End With
      destRow = destRow + 1
    Next key
  End With
Call جمع_القيم_بشرط_محسن
End Sub

    Sub جمع_القيم_بشرط_محسن()
  Dim wsSheet1 As Worksheet, wsResid As Worksheet
  Dim lastRowSheet1 As Long, lastRowResid As Long
  Dim i As Long, j As Long
  Dim itemCodeSheet1 As String, itemCodeResid As String
  Dim valueToSum As Double, sumValue As Double
  ' Set worksheets
  Set wsSheet1 = ThisWorkbook.Sheets("Sheet3")
  Set wsResid = ThisWorkbook.Sheets("رصيد")
  ' Find last rows
  lastRowSheet1 = wsSheet1.Cells(Rows.Count, 1).End(xlUp).Row
  lastRowResid = wsResid.Cells(Rows.Count, 1).End(xlUp).Row
  ' Loop through "الرصيد" sheet
  For j = 2 To lastRowResid
    itemCodeResid = CStr(wsResid.Cells(j, 1).Value) ' Convert to string
    sumValue = 0
    ' Loop through "شيت1" sheet
    For i = 2 To lastRowSheet1
      itemCodeSheet1 = CStr(wsSheet1.Cells(i, 7).Value) ' Convert to string
      valueToSum = CDbl(wsSheet1.Cells(i, 3).Value)
      ' Check if item codes match
      If itemCodeSheet1 = itemCodeResid Then
        ' Check if value is numeric to avoid errors
        If IsNumeric(valueToSum) Then
          sumValue = sumValue + valueToSum
        End If
      End If
    Next i
    ' Write the sum to "الرصيد" sheet
    wsResid.Cells(j, 5).Value = sumValue
  Next j
End Sub

 

اجمالى2 - Copy.xlsm

تم تعديل فبراير 10 بواسطه mahmoud nasr alhasany

[mahmoud nasr alhasany]

Sub تصدير_بيانات_و_تجميعها()

  Dim wsSource As Worksheet, wsDest As Worksheet
  Dim lastRow As Long, i As Long, destRow As Long
  Dim itemCode As String, itemName As String, itemUnit As String
  Dim itemPrice As Double, cartnCount As Long
  Dim dict As Object ' Dictionary to store unique items
  Dim key As Variant ' To loop through dictionary keys efficiently

  ' Set the source and destination worksheets
  Set wsSource = ThisWorkbook.Sheets("Sheet3") ' Change "Sheet3" to your source sheet name
  Set wsDest = ThisWorkbook.Sheets("رصيد") ' Change "رصيد" to your destination sheet name

  ' Find the last row in the source sheet (start from row 2 to avoid headers)
  lastRow = wsSource.Cells(Rows.Count, 7).End(xlUp).Row
  If lastRow < 2 Then Exit Sub ' Exit if no data

  ' Create a dictionary to store unique items
  Set dict = CreateObject("Scripting.Dictionary")

  ' Initialize destination row
  destRow = 2 ' Start from row 2 (assuming row 1 is for headers)

  ' Loop through each row in the source sheet
  For i = 2 To lastRow

    ' Get item code and name
    itemCode = Trim(wsSource.Cells(i, 7).Value) ' Trim whitespace
    itemName = Trim(wsSource.Cells(i, 6).Value) ' Trim whitespace
    itemUnit = Trim(wsSource.Cells(i, 4).Value) ' Trim whitespace
    itemPrice = CDbl(wsSource.Cells(i, 5).Value) ' Convert to Double, handle errors later
    cartnCount = CLng(wsSource.Cells(i, 3).Value) ' Convert to Long, handle errors later

    ' Skip rows with empty item codes
    If itemCode = "" Then GoTo NextIteration

    ' Add new item to dictionary or update existing
    If Not dict.Exists(itemCode) Then
      dict.Add itemCode, Array(itemName, itemUnit, itemPrice, cartnCount)
    Else
'      dict(itemCode)(3) = dict(itemCode)(3) + cartnCount
    End If

NextIteration:
  Next i

  ' Write headers to the destination sheet
  With wsDest
    .Cells(1, 1).Value = "كود الصنف"
    .Cells(1, 2).Value = "اسم الصنف"
    .Cells(1, 3).Value = "وحدة الصنف"
    .Cells(1, 4).Value = "سعر الصنف"
    .Cells(1, 5).Value = "عدد الكراتين"

    ' Loop through the dictionary and write data to the destination sheet
    For Each key In dict.Keys ' More efficient way to loop
      With .Cells(destRow, 1)
        .Value = key
        .Offset(0, 1).Value = dict(key)(0) ' itemName
        .Offset(0, 2).Value = dict(key)(1) ' itemUnit
        .Offset(0, 3).Value = dict(key)(2) ' itemPrice
        .Offset(0, 4).Value = dict(key)(3) ' cartnCount
      End With
      destRow = destRow + 1
    Next key
  End With
Call جمع_القيم_بشرط_محسن_جدا
End Sub

    Sub جمع_القيم_بشرط_محسن_جدا()

    Dim wsSheet1 As Worksheet, wsResid As Worksheet
    Dim lastRowSheet1 As Long, i As Long
    Dim itemCodeSheet1 As String
    Dim valueToSum As Double
    Dim dict As Object ' Dictionary to store sums for each item code

    ' Set worksheets
    Set wsSheet1 = ThisWorkbook.Sheets("Sheet3")
    Set wsResid = ThisWorkbook.Sheets("رصيد")

    ' Find last row in Sheet1
    lastRowSheet1 = wsSheet1.Cells(Rows.Count, 7).End(xlUp).Row ' Check column 7 for last row

    ' Create a dictionary to store the sums
    Set dict = CreateObject("Scripting.Dictionary")

    ' Loop through Sheet1 to sum values
    For i = 2 To lastRowSheet1

        itemCodeSheet1 = CStr(wsSheet1.Cells(i, 7).Value) ' Convert item code to string

        ' Try converting value to double, handle non-numeric values
        On Error Resume Next ' Enable error handling
        valueToSum = CDbl(wsSheet1.Cells(i, 3).Value) ' Try converting to Double
        On Error GoTo 0 ' Disable error handling

        ' Add to dictionary or update if exists
        If dict.Exists(itemCodeSheet1) Then
            dict(itemCodeSheet1) = dict(itemCodeSheet1) + valueToSum
        Else
            dict.Add itemCodeSheet1, valueToSum
        End If

    Next i

    ' Write headers to "رصيد" sheet (if needed)
    wsResid.Cells(1, 1).Value = "كود الصنف"
    wsResid.Cells(1, 5).Value = "المجموع"

    ' Write sums to "رصيد" sheet
    Dim destRow As Long
    destRow = 2 ' Start from row 2

    Dim key As Variant
    For Each key In dict.Keys
        wsResid.Cells(destRow, 1).Value = key
        wsResid.Cells(destRow, 5).Value = dict(key)
        destRow = destRow + 1
    Next key
 ' Add total row
    wsResid.Cells(destRow, 1).Value = "المجموع الكلي" ' Label for total row
    wsResid.Cells(destRow, 5).Formula = "=SUM(E2:E" & (destRow - 1) & ")" ' Formula to calculate total
    wsResid.Cells(destRow, 6).Formula = "=SUM(F2:F" & (destRow - 1) & ")" ' Formula to calculate total
    wsResid.Cells(destRow, 7).Formula = "=SUM(G2:G" & (destRow - 1) & ")" ' Formula to calculate total
    wsResid.Cells(destRow, 8).Formula = "=SUM(H2:H" & (destRow - 1) & ")" ' Formula to calculate total
MsgBox "تمت العملية بنجاح!"
End Sub

 

[محمد هشام.]

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

رغم أنني ليس متأكدا من طلبك بسبب كثرة الأكواد التي قمت بإرفاقها  

 بالنسبة لعمود  F   (اجمالى ك وق)  لا يمكن جمع القيم مباشرة إذا كانت مخزنة كنص باستخدام الدالة TEXT  أعتقد انه يمكنك تجاوز هذه المشكلة بتعديل الكود  لجمع القيم العددية مباشرة دون الحاجة إلى الصيغة TEXT  مع الاحتفاظ بالصيغ في الأعمدة الأخرى 

Option Explicit
Sub Test()
    Dim WS As Worksheet, dest As Worksheet, dict As Object
    Dim Code, name, Unit As String
    Dim cartn, Price, tmp, ColF As Double
    Dim ColArr, col, key, ColHard As Variant
    Dim lastRow, i, Irow As Long
    
    Set WS = Sheets("Sheet3"): Set dest = Sheets("رصيد")
    lastRow = WS.Cells(Rows.Count, 7).End(xlUp).Row
    If lastRow < 2 Then Exit Sub
    
   ColHard = Array("كود الصنف", "اسم الصنف", "وحدة الصنف", "سعر الصنف", "عدد الكراتين", "إجمالي ك وق", "ك", "ق")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    dest.Range("A2:H" & dest.Rows.Count).ClearContents
    Application.ErrorCheckingOptions.BackgroundChecking = False
    Set dict = CreateObject("Scripting.Dictionary")
    Irow = 2

    For i = 2 To lastRow
        Code = Trim(CStr(WS.Cells(i, 7).value))
        name = Trim(WS.Cells(i, 6).value)
        Unit = Trim(WS.Cells(i, 4).value)
        Price = Val(WS.Cells(i, 5).value)
        cartn = Val(WS.Cells(i, 3).value)

        If Code <> "" Then
            If dict.Exists(Code) Then
                dict(Code)(3) = dict(Code)(3) + cartn
            Else
                dict.Add Code, Array(name, Unit, Price, cartn)
            End If
        End If
    Next i

    With dest
        .Range("A1:H1").value = ColHard
        For Each key In dict.Keys
            .Cells(Irow, 1).value = key
            .Cells(Irow, 2).Resize(1, 4).value = dict(key)

            .Cells(Irow, 7).Formula = "=INT(E" & Irow & "/C" & Irow & ")"
            .Cells(Irow, 8).Formula =  "=MOD(E" & Irow & ",C" & Irow & ")"

            Irow = Irow + 1
        Next key

        .Cells(Irow, 1).value = "المجموع الكلي"
        ColF = 0

        For i = 2 To Irow - 1
            If .Cells(i, 5).value <> 0 And .Cells(i, 3).value <> 0 Then
                tmp = Int(.Cells(i, 5).value / .Cells(i, 3).value) + (.Cells(i, 5).value Mod _
                                                    .Cells(i, 3).value) / .Cells(i, 3).value
            Else
                tmp = 0
            End If
            .Cells(i, 6).value = Format(tmp, "0.0")
            ColF = ColF + tmp
        Next i
        
        .Cells(Irow, 6).value = Format(ColF, "0.0")
        
        ColArr = Array("E", "G", "H")
        For Each col In ColArr
            .Cells(Irow, col).Formula = "=SUM(" & col & "2:" & col & (Irow - 1) & ")"
        Next col
    End With
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "تمت العملية بنجاح", vbInformation
End Sub

 

اجمالى2 V1.xlsm

تم تعديل فبراير 12 بواسطه محمد هشام.

[mahmoud nasr alhasany]

احسنت استاذنا / محمد هشام.

هذا هو المطلوب