تقسيم حقل جدول على مجموعات متساوية

[dalas2]

كيفية فرز حقل في مجموعة متساوية في اكسيس

1.2

2.5

1.5

1.8

2

1.5

1

2

مجموع ارقام : 2.5 +1.5+2=6

ايضا مجموع ارقام : 1.2+1.8+1+2=6

لازم اجمالى ارقام  فرعية متساوية

شكرا....

[jjafferr]

وعليكم السلام

 

السؤال غير واضح ، فلوسمحت تعطي توضيح اكثر.

 

جعفر

[dalas2]

السلام عليكم استاذ جعفر 

اريد ترتيب جدول حتى مجموع كل فرع تساوى 6. اذا ادخال ارقام فى حقل اسعار :1.2  2.5   1.5   1.8    2   1.5   1  2

لازم يرتب جدول حتى اجمال مجموعات متساوية:اى يرتب جدول بهذا شكل:  2.5    1.5  2  1.2  1.8  1  2 

 

[jjafferr]

1. ما دام الجدول عندك جاهز , فرجاء ارفاقه ، والا سأضطر انا لعمل الجدول 

2. اللي افهمه من شرحك هو:

السعر 1.2 + 6. = 1.8 وليس 2.5 !!

معلش ، اخذ من وقتك اكثر شوي واشرح بمثال عن كيف تريد ان تكون النتيجة النهائية

 

جعفر

[dalas2]

Database200.rar

[jjafferr]

السلام عليكم 

 

انا بحثت عن مثل هذا سؤال ، فوجدت الرابط التالي ، ومرفق صورة من النتيجة ، وملف الاكسل ايضا:

https://excelxor.files.wordpress.com/2015/02/which-numbers-add-up-to-total-multiple-solutions2.xlsx

.

وكذلك وجدت مثال على vba واضطررت التعديل عليه ليناسب طلبك ، فهذه الوحدة النمطية الاساسية:

Option Compare Database
Option Explicit

    Dim rst As DAO.Recordset
'
'from
'http://stackoverflow.com/a/21076070
'Edited by jjafferr on 29/11/2016
'

Function SumTarget()
    Dim numbers(0 To 6)  As Double
    Dim target As Double
    Dim i As Integer

    target = DSum("[Price]", "t1") / 2
    Call modArray_StatesInAnArray
    For i = 0 To Record_Count - 1
        numbers(i) = strState(i)
    Next i

    
    CurrentDb.Execute ("Delete * From tbl_Results")                 'delete all the results from the table
    Set rst = CurrentDb.OpenRecordset("Select * From tbl_Results")  'set the table for the entries
    
    Call SumUpTarget(numbers, target)
    
    rst.Close: Set rst = Nothing
    
End Function

Public Sub SumUpTarget(numbers() As Double, target As Double)
    Dim part() As Double
    Call SumUpRecursive(numbers, target, part)
End Sub

Private Sub SumUpRecursive(numbers() As Double, target As Double, part() As Double)

    Dim s As Double, i As Double, j As Double, num As Double
    Dim remaining() As Double, partRec() As Double
    s = SumArray(part)

    'If s = target Then Debug.Print "SUM ( " & ArrayToString(part) & " ) = " & target
    If s = target Then
        rst.AddNew
        rst![Target_Number] = target: rst!Results = ArrayToString(part)
        rst.Update
    ElseIf s >= target Then
        Exit Sub

    ElseIf (Not Not numbers) <> 0 Then
        For i = 0 To UBound(numbers)
            Erase remaining()
            num = numbers(i)
            For j = i + 1 To UBound(numbers)
                AddToArray remaining, numbers(j)
            Next j
            Erase partRec()
            CopyArray partRec, part
            AddToArray partRec, num
            SumUpRecursive remaining, target, partRec
        Next i
    End If

End Sub

Private Function ArrayToString(x() As Double) As String
    Dim n As Double, result As String
    'result = "{" & x(n)
    result = x(n)
    For n = LBound(x) + 1 To UBound(x)
        'result = result & "," & x(n)
        result = result & "+" & x(n)
    Next n
    result = result '& "}"
    ArrayToString = result
End Function

Private Function SumArray(x() As Double) As Double
    Dim n As Double
    SumArray = 0
    If (Not Not x) <> 0 Then
        For n = LBound(x) To UBound(x)
            SumArray = SumArray + x(n)
        Next n
    End If
End Function

Private Sub AddToArray(arr() As Double, x As Double)
    If (Not Not arr) <> 0 Then
        ReDim Preserve arr(0 To UBound(arr) + 1)
    Else
        ReDim Preserve arr(0 To 0)
    End If
    arr(UBound(arr)) = x
End Sub

Private Sub CopyArray(destination() As Double, source() As Double)
    Dim n As Double
    If (Not Not source) <> 0 Then
        For n = 0 To UBound(source)
                AddToArray destination, source(n)
        Next n
    End If
End Sub

والتي تطلب البيانات من هذه الوحدة النمطية:

Option Compare Database

    Const lngArraySize = 20
    Public strState(lngArraySize)
    Public lngCounter As Long
    Public Record_Count As Integer
    

Function modArray_StatesInAnArray()
    ' loads a list of states into an array of fixed size
    'Const lngArraySize = 20
    'Dim lngCounter As Long
    Dim varAState As Variant ' needs to be a variant for
    ' use in the ForEach loop
    'Dim strState(lngArraySize)
    Dim db As Database
    Dim sl As Long

    Set db = CurrentDb
    lngCounter = 0
    sl = 0

    Dim rst As Recordset
    Set rst = db.OpenRecordset("Select * From t1")
    rst.MoveLast: rst.MoveFirst
    Record_Count = rst.RecordCount
    
    Do While Not rst.EOF

'If sl < 6 Then
'sl = sl + rst!price
'rst.Edit
'rst!priceSort = rst!price
'rst.Update

'this would cause a problem
'End If

        strState(lngCounter) = rst!price
        lngCounter = lngCounter + 1
        rst.MoveNext
    Loop

'    For I = 0 To lngCounter
'        Debug.Print strState(I)
'    Next I


End Function

ولتشغيل الوحدات النمطية ، نضع هذا الكود على حدث زر في النموذج:

Call SumTarget

 

والنتيجة تحفظ في الجدول tbl_Results:

.

جعفر

460.Database200.accdb.zip

460.which-numbers-add-up-to-total-multiple-solutions2.xlsx.zip

[dalas2]

السلام عليكم

شكرا لك اخي الكريم جعفر