Excel VBA:تبحث عن المشورة تجنب حلقة لا نهائية

https://stackoverflow.com//questions/25088848

02-01-2020
|

سؤال

Imgur الألبوم مع شاشات أوراق العمل: http://imgur.com/a/6rFWF

قصة قصيرة طويلة, أنا أكتب Excel VBA الأداة التي سيتم تعيين نوعين من الأمن التحولات (يسمى التغطيات نهاية الأسبوع والرسوم) إلى أمن الموظفين.في الأساس لدي ورقة عمل مع كل من الموظفين ومن مختلف توافر المعلومات في ذلك (أعلى الصورة في imgur ألبوم) ورقة عمل مع كل من التغطية التواريخ في ذلك (أسفل الصورة في imgur ألبوم).علما بأن ليس لدي صورة من عطلة نهاية الأسبوع واجب التواريخ كما يبدو مشابها التغطية التواريخ (ولكن مع الجمعة و السبت التحولات).

الأداة الأساس يعين عشوائي الموظف إلى كل تاريخ التحقق للتأكد من أنها لا تنتهك أي من توافر المتطلبات.للأسف, وأنا أدرك أن أنا خلق فرصة كبيرة من أجل حلقة لا نهائية تحدث.في بلدي التجارب ، هناك فقط 1 محاولة للخروج من حوالي 15-16 التي لم تدخل حلقة لا نهائية قرب النهاية.لذا أنا أبحث عن مساعدتكم على حساب لهذا فائدة لا تأكل نفسها.

هنا هو "الزائفة رمز" لهذا الإجراء في السؤال.

'Loop for Column A in the Coverage Slips sheet (image 2 in imgur album)
Do Until (CoverageRowNumber = LastCoverageSlipRow + 1)
    Get a Random Staff Member by RNG
    If staff member still needs more shifts (see Requirements columns) Then
        If staff member does not have an "X" under the day of the week Then
            If staff member does not have a matching date conflict Then
                Assign the coverage
                Increase CoverageRowNumber
            End If
        End If
     End If
Loop

'Loop for Column B in the coverage slips sheet (image 2 in imgur album)
Do Until...

    Same as the loop above

Loop

تحرير:تجاهل بأن لدي مواعيد في عمودين الآن.سوف يتم تحديد أنه بمجرد حل مشكلة هذا المنصب...هو حل سهل و قطع رمز إلى النصف تقريبا.

المشكلة هي أن مثل فائدة يحصل قرب نهاية قائمة من التواريخ ، فإنه غالبا ما يعمل في سيناريو حيث الموظفين فقط لا يمكن ترك الجلوس محددة التحول (سواء بسبب يوم من أيام الأسبوع أو في تاريخ محدد).في حال أنه يعمل في هذا السيناريو ، أستطيع أن أرى بضعة خيارات مقبولة (على الرغم من أنني لا أعرف كيف أذهب عن البرمجة منهم):

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

هل لديكم أي أفكار يمكن أن تساعد هنا ؟ أنا حتى لست متأكدا كيف يمكن أن يكون الإجراء تحقق لمعرفة ما إذا كان هناك أي خيارات متاحة أو لا ، ولكن في كلتا الحالتين يجب أن يكون هناك وسيلة للكشف عن (وردع) هذه حلقة لا نهائية قبل تعطل البرنامج.

آسف على الرواية و شكرا مقدما على أي مساعدة!

تحرير:في محاولة لتوفير المزيد من الوضوح فكرت نسخ ولصق رمز الفعلي أدناه:

'------------------------------------------------------------'
'Create ws variables for each worksheet
Dim wsConflicts As Worksheet
Dim wsCoverageSlips As Worksheet
Dim wsWDSlips As Worksheet
Dim wsCoverageOutput As Worksheet
Dim wsWDOutput As Worksheet

'------------------------------------------------------------'
Public Function SetSheets()
'Assign the worksheets to the ws variables
    Set wsConflicts = Worksheets("Conflicts")
    Set wsCoverageSlips = Worksheets("Coverage Slips")
    Set wsWDSlips = Worksheets("WD Slips")
    Set wsCoverageOutput = Worksheets("Coverage Output")
    Set wsWDOutput = Worksheets("WD Output")

'Display a message (debugging)
    'MsgBox "The sheets have been assigned successfully"

End Function

'------------------------------------------------------------'
Public Function ColumnLetter(ColumnNumber As Integer) As String
    Dim n As Long
    Dim c As Byte
    Dim s As String

    n = ColumnNumber
    Do
        c = ((n - 1) Mod 26)
        s = Chr(c + 65) & s
        n = (n - c) \ 26
    Loop While n > 0
    ColumnLetter = s
End Function

'------------------------------------------------------------'
Sub AssignCoverages()
'Fill the ws variables
    Call SetSheets

'Set the first and last row numbers
    Dim FirstStaffMemberRow As Integer
        FirstStaffMemberRow = 3
    Dim LastStaffMemberRow As Integer
        LastStaffMemberRow = wsConflicts.UsedRange.Rows.Count

'Count the number of required coverages and weekend duties
    Dim RequiredCoverages As Integer
    Dim RequiredWDs As Integer
    For i = FirstStaffMemberRow To LastStaffMemberRow
        RequiredCoverages = RequiredCoverages + wsConflicts.Range("B" & i).Value
        RequiredWDs = RequiredWDs + wsConflicts.Range("C" & i).Value
    Next i

'Display a message (debugging)
    MsgBox "You currently have " & RequiredCoverages & " required coverages and " & RequiredWDs & " required weekend duties."

'Count the number of coverage slips and weekend duty slips
Dim FirstCoverageSlipRow As Integer
    FirstCoverageSlipRow = 1
Dim LastCoverageSlipRow As Integer
    LastCoverageSlipRow = wsCoverageSlips.UsedRange.Rows.Count
Dim NumCoverageSlips As Integer
    NumCoverageSlips = (LastCoverageSlipRow - FirstCoverageSlipRow + 1)
Dim FirstWDSlipRow As Integer
    FirstWDSlipRow = 1
Dim LastWDSlipRow As Integer
    LastWDSlipRow = wsWDSlips.UsedRange.Rows.Count
Dim NumWDSlips As Integer
    NumWDSlips = (LastWDSlipRow - FirstWDSlipRow + 1)

'Check to make sure there are enough required shifts for slips
    If RequiredCoverages <> NumCoverageSlips Then
        MsgBox "The number of shifts you require (Columns B & C on Conflicts sheet) does not match the number of slips you've entered.  You have " & RequiredCoverages & " required coverages and " & NumCoverageSlips & " coverage slips.  You have " & RequiredWDs & " required weekend duties and " & NumWDSlips & " weekend duty slips.  Please correct this error and retry."
        Exit Sub
    Else
        'Debugging
        'MsgBox "The number of shifts you require (Columns B & C on Conflicts sheet) matches the number of slips you've entered.  You have " & RequiredCoverages & " required coverages and " & NumCoverageSlips & " coverage slips.  You have " & RequiredWDs & " required weekend duties and " & NumWDSlips & " weekend duty slips."
    End If

'Massive loop to assign coverages to random staff members
    Dim NumRemainingCoverages As Integer
        NumRemainingCoverages = NumCoverageSlips
    Dim SlipRowNumber As Integer
        SlipRowNumber = FirstCoverageSlipRow
'Loop for Column A
    Do Until (SlipRowNumber = LastCoverageSlipRow + 1)
        'Get a random staff member row
        StaffMemberRow = GetRandomStaffMemberRow(FirstStaffMemberRow, LastStaffMemberRow)

        'Check to make sure the staff member has remaining required coverages
        If wsConflicts.Range("B" & StaffMemberRow).Value > 0 Then

            'Check to make sure the staff member can sit the day of the week
                Dim CurrentDate As Date
                    CurrentDate = wsCoverageSlips.Range("A" & SlipRowNumber).Value
                Dim CurrentDay As Integer
                    CurrentDay = Weekday(CurrentDate)
                Dim CurrentDayColumn As String
                    If CurrentDay = 1 Then CurrentDayColumn = "D"
                    If CurrentDay = 2 Then CurrentDayColumn = "E"
                    If CurrentDay = 3 Then CurrentDayColumn = "F"
                    If CurrentDay = 4 Then CurrentDayColumn = "G"
                    If CurrentDay = 5 Then CurrentDayColumn = "H"
                    If CurrentDay = 6 Then CurrentDayColumn = "I"
                    If CurrentDay = 7 Then CurrentDayColumn = "J"
                If wsConflicts.Range(CurrentDayColumn & StaffMemberRow).Value = "" Then

                'Check to make sure the staff member does not have a date conflict
                    Dim ColumnNumber As Integer
                    Dim ColumnLetterText As String
                    Dim CoverageDateConflicts As Integer
                        CoverageDateConflicts = 0
                    For ColumnNumber = 11 To 20
                        ColumnLetterText = ColumnLetter(ColumnNumber)
                        Dim CoverageSlipDate As Date
                        If IsDate(wsConflicts.Range(ColumnLetterText & StaffMemberRow).Value) = True Then
                            CoverageSlipDate = wsConflicts.Range(ColumnLetterText & StaffMemberRow).Value
                        Else
                            CoverageSlipDate = DateValue("01/01/1900")
                        End If
                        If CurrentDate = CoverageSlipDate Then
                            CoverageDateConflicts = CoverageDateConflicts + 1
                        End If
                    Next ColumnNumber
                    If CoverageDateConflicts = 0 Then

                    'Assign the coverage
                        Dim BlankCoverageOutputRow As Integer
                            BlankCoverageOutputRow = wsCoverageOutput.UsedRange.Rows.Count + 1
                        wsCoverageOutput.Range("A" & BlankCoverageOutputRow).Value = wsConflicts.Range("A" & StaffMemberRow).Value
                        wsCoverageOutput.Range("B" & BlankCoverageOutputRow).Value = CurrentDate

                    'Reduce the staff member's required coverages by 1
                        Dim CurrentRequirements As Integer
                            CurrentRequirements = wsConflicts.Range("B" & StaffMemberRow).Value
                            wsConflicts.Range("B" & StaffMemberRow).Value = CurrentRequirements - 1

                    'Reduce the number of remaning coverages by 1
                        NumRemainingCoverages = NumRemainingCoverages - 1

                    'Increase the slip row number by 1
                        SlipRowNumber = SlipRowNumber + 1

                    'Message box for debugging
                        'MsgBox "Coverage Date (" & CurrentDate & ") assigned to " & wsConflicts.Range("A" & StaffMemberRow).Value & "."

                    End If 'End date check

                End If 'End day check

        End If 'End requirements check

    Loop 'End loop for column A

End Sub

'------------------------------------------------------------'
Public Function GetRandomStaffMemberRow(FirstStaffMemberRow As Integer, LastStaffMemberRow As Integer)
'Pick a random number between the first staff member row and the last
    Call Randomize
    GetRandomStaffMemberRow = Int((LastStaffMemberRow - FirstStaffMemberRow + 1) * Rnd + FirstStaffMemberRow)
End Function

المحلول 2

لذلك ذهبت إلى الأمام وتطوير حلا خاصتي لهذه المشكلة - إنها ليست مثالية، وربما ليست أفضل طريقة للتعامل مع السيناريو. لكنه يعمل، وحل مشكلتي في غضون دقائق بدلا من ساعات تعلم طرق أخرى.

أساسا، قمت بإنشاء اثنين من المتغيرات الجديدة "العداد". الأول فشل. في كل مرة يحاول فيها الإجراء موظفا عشوائي، لكنه يعمل في صراع، فهو يزيد من فاشلة الفاشلة عن طريق 1. في كل مرة يكون فيها الموظف العشوائي هو مباراة ناجحة (بدون تعارضات)، فإنه يعيد تعيين فاشلة الفاشلة إلى 0. إذا فشل في أي وقت= 100، إنه يخرج على الفور الحلقة ويبدأ أكثر من ذلك. بمعنى آخر، إذا حاول 100 موظف عشوائي على التوالي دون العثور على مباراة، أفترض أنه لن يجد مباراة وفقط خسائر الخسائر الخاصة بي.

المتغير الثاني، المهام، يتم تزويده بنسبة 1 في كل مرة يقوم بها الإجراء بمهمة ناجحة. عندما يساوي هذا الرقم عدد التحولات التي من المفترض أن يقوم الإجراء بتعيينها، فإنه يخرج على الفور الحلقة.

للقيام بذلك، اضطررت إلى استخدام أوامر "GOTO" المحظورة (لم أكن متأكدا من عدم التأكد من الخروج من الحلقة. يمكنك الخروج من حلقة مع الخروج ولكنني أعتقد أن هذا غير صالح للقيام بذلك حلقات. انتهى الأمر بحتاج فقط إلى اثنين من GOTO، واحد لإخراج الحلقة والعودة إلى بداية الإجراء. كما أنه بالتأكد من إعادة تعيين الخلايا في ورقة العمل التي تتغير أثناء الإجراء إلى حالتها الأصلية قبل ذلك إعادة محاولة إجراء المهمة.

سأقوم بإنقاذ الجميع مشكلة في القراءة من خلال الإصدار الموسع من التعليمات البرمجية، ولكن في النموذج "الرمز الزائدي" يبدو مثل هذا:

giveacodicetagpre.

مرة أخرى، قد يكون هناك طريقة (وبالتأكيد) طريقة أكثر أناقة و "صحيحة" لإنجاز المهمة في متناول اليد. هذه الطريقة عملت لي مع البيئة المحددة. بفضل أولئك الذين قدموا حلولا - على الرغم من أنني انتهيت من الذهاب إلى اتجاه مختلف قدمو طعاما رائعا للفكر وساعدني في تعلم مجموعة من الأساليب الجديدة (خاصة فكرة الفصل من @ stenci).

شكرا كل شيء.

نصائح أخرى

السؤال هو أيضا مفتوح إجابة مفصلة ، لذلك أنا أحاول مع بعض المبادئ التوجيهية.وآمل أن يساعد.

وأود أن استخدام فئة Solution مع الأعضاء التالية أسماؤهم:

Solution.ReadInputFromSheet() يقرأ الجدول من ورقة إلى أعضاء الفئة

Solution.GenerateRandom() يخلق عشوائية جديدة الحل.في محاولة لإيجاد توازن بين الذكية (إضافة بعض المنطق لتجنب عشوائية تماما الحلول) و السرعة (لا تتعثر الخروج بعد محاولة 10 أو 50 الأرقام العشوائية التي لا تعمل) ، ولكن السرعة هي أكثر أهمية

Solution.Quality() As Double يحسب نوعية من الحل.على سبيل المثال حل غير صحيح بإرجاع 0, إذا جو 10 على التوالي في التحولات عوائد 20, إذا كان التحولات أفضل توزيع عوائد 100.

Solution.WriteOnSheet() كتابة البيانات من أعضاء الفئة في ورقة.

Solution.Clone() As Solution() يخلق جديد Solution سبيل المثال مع نفس البيانات

جعل دورة يخلق الحل الشيكات إذا كانت الجودة أفضل من أفضل نوعية الحل وجدت حتى الآن ، إذا فمن الأفضل الاحتفاظ بها ، وإلا انتقل وحساب حل آخر.

Set BestS = New Solution
BestS.ReadInputFromSheet
BestS.GenerateRandom()

Set S = New Solution
S.ReadInputFromSheet
For I = 1 To 10000
  S.GenerateRandom()
  If S.Quality() > BestS.Quality() Then Set BestS = S.Clone()
Next I
BestS.WriteOnSheet

بدلا من 10000 يمكنك استخدام Timer لتشغيله على عدد محدود من ثانية, أو جعل زر أن يقطع ذلك عندما كنت أعود من استراحة الغداء.

أسرع حل مولد وظيفة أفضل من المخاطرة في الحصول على عالقا مع واحد يصعب (أو يستحيل) الحل.

من أجل حل أكثر ذكاء مولد وظيفة أحتاج لمزيد من التفاصيل على القواعد.

مرخصة بموجب: CC-BY-SA مع الإسناد

لا تنتمي إلى StackOverflow