Извлекать, удалять дубликаты и всех ингредиентов в массиве


первый раз

второй раз

Примечание: входное питание сведения проверены - он не может быть то, что не существует на лист поиск. Листы всех зовут, как и именованные диапазоны.

Качестве (в формате Excel) пользователь выбирает из пищи, а затем создает PopulateShoppingList список покупок().

Это выбор, смотрит их на соответствующий лист, собирает ингредиенты и обеспечивает нет повторяющихся ингредиентов.

Я сделал некоторые хитрости, рефакторинг некоторых PopulateShoppingList()добавил GetMealList, ExpandArray и IsInArray.

Мне удалось избавиться от моей метки в GetIngredients и удалось сделать изменения размера массива до одного уровня код. Все-таки я чувствую, что я упускаю какую-то рефакторинг в GetIngredients. В целом я сделал улучшения, но кажется, что я сделал код больше и не удалось убрать много абстракции - есть еще 4 For Next петли

Option Explicit

Public Sub PopulateShoppingList()

    Dim BreakfastArea As Range
    Set BreakfastArea = wsPlan.Range("BreakfastArea")

    Dim SnackAreaAM As Range
    Set SnackAreaAM = wsPlan.Range("SnacksAreaAM")

    Dim LunchArea As Range
    Set LunchArea = wsPlan.Range("LunchArea")

    Dim SnackAreaPM As Range
    Set SnackAreaPM = wsPlan.Range("SnacksAreaPM")

    Dim DinnerArea As Range
    Set DinnerArea = wsPlan.Range("DinnerArea")

    Dim ListArea As Range
    Set ListArea = wsPlan.Range("ListArea")
    ListArea.ClearContents

    Dim ingredientList As Variant
    ReDim ingredientList(1, 0)

    Dim mealList As Variant
    mealList = GetMealList(BreakfastArea)
    If Not IsEmpty(mealList) Then GetIngredients wsBreakfast, mealList, ingredientList
    mealList = GetMealList(LunchArea)
    If Not IsEmpty(mealList) Then GetIngredients wsLunch, mealList, ingredientList
    mealList = GetMealList(DinnerArea)
    If Not IsEmpty(mealList) Then GetIngredients wsDinner, mealList, ingredientList
    mealList = GetMealList(SnackAreaAM)
    If Not IsEmpty(mealList) Then GetIngredients wsSnacks, mealList, ingredientList
    mealList = GetMealList(SnackAreaPM)
    If Not IsEmpty(mealList) Then GetIngredients wsSnacks, mealList, ingredientList


    If Not IsEmpty(ingredientList(0, 0)) Then WriteShoppingList ingredientList

End Sub

Private Function GetMealList(ByVal targetArea As Range) As Variant
    Dim numberOfMeals As Long
    Dim listIndex As Long
    listIndex = 0
    Dim meal As Range
    numberOfMeals = Application.WorksheetFunction.CountA(targetArea)
    If numberOfMeals = 0 Then Exit Function
    Dim mealList() As String
    ReDim mealList(numberOfMeals - 1)
    For Each meal In targetArea
        If Not meal = vbNullString Then
            mealList(listIndex) = meal.Value
            listIndex = listIndex + 1
        End If
    Next
    GetMealList = mealList
End Function

Private Sub GetIngredients(ByVal targetSheet As Worksheet, ByVal mealList As Variant, ByRef ingredientList As Variant)
    Dim sheetRow As Long
    Dim mealIndex As Long
    Dim mealName As String
    Dim mealRow As Long
    Dim arrayIndex As Long
    Dim sheetLastRow As Long
    Dim mealLastRow As Long
    Dim expandBy As Long
    Dim newIngredient As Long

    With targetSheet
        sheetLastRow = .Cells(.Rows.count, 2).End(xlUp).Row
        For mealIndex = LBound(mealList) To UBound(mealList)
            mealName = mealList(mealIndex)
            For sheetRow = 2 To sheetLastRow
                If targetSheet.Cells(sheetRow, 1) = mealName Then
                    mealLastRow = .Columns(1).Find(what:="*", after:=.Cells(sheetRow, 1), LookIn:=xlValues).Row
                    If mealLastRow = 1 Then
                        mealLastRow = .Columns(2).Find(what:=vbNullString, after:=.Cells(sheetRow, 2), LookIn:=xlValues).Row
                    End If
                    newIngredient = UBound(ingredientList, 2)
                    expandBy = ExpandArray(.Range(.Cells(sheetRow, 2), .Cells(mealLastRow - 1, 2)), ingredientList)
                    ReDim Preserve ingredientList(1, newIngredient + expandBy)
                    For mealRow = sheetRow To mealLastRow - 1

                        If Not IsInArray(.Cells(mealRow, 2), ingredientList) Then
                            ingredientList(0, newIngredient) = .Cells(mealRow, 2)
                            ingredientList(1, newIngredient) = .Cells(mealRow, 3)
                            newIngredient = newIngredient + 1
                        Else:
                            For arrayIndex = LBound(ingredientList, 2) To newIngredient
                                If ingredientList(0, arrayIndex) = .Cells(mealRow, 2) Then
                                    ingredientList(1, arrayIndex) = ingredientList(1, arrayIndex) + .Cells(mealRow, 3)
                                    Exit For
                                End If
                            Next arrayIndex
                        End If
                    Next mealRow
                End If
            Next sheetRow
        Next mealIndex
    End With
End Sub

Private Function ExpandArray(ByVal targetRange As Range, ByVal ingredientsList As Variant) As Long
    Dim count As Long
    Dim ingredient As Variant
    Dim newIngredient As Range
    For Each newIngredient In targetRange
        For Each ingredient In ingredientsList
            If ingredient = newIngredient Then GoTo Exists
        Next
        count = count + 1
Exists:
    Next newIngredient
    ExpandArray = count
End Function

Private Function IsInArray(ByVal ingredient As String, ByVal ingredientList As Variant) As Boolean
    Dim element As Variant
    For Each element In ingredientList
        If element = ingredient Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

Private Sub WriteShoppingList(ByVal ingredientList As Variant)
    Const LIST_FIRST_ROW As Long = 14
    Const LIST_LAST_ROW As Long = 29
    Const LIST_FIRST_COLUMN As Long = 2
    Const LIST_LAST_COLUMN As Long = 8
    Dim arrayIndex As Long
    Dim listItem As String

    arrayIndex = 0
    Dim sheetRow As Long
    sheetRow = LIST_FIRST_ROW
    Dim columnIndex As Long
    columnIndex = LIST_FIRST_COLUMN

    For arrayIndex = LBound(ingredientList, 2) To UBound(ingredientList, 2)
        listItem = ingredientList(1, arrayIndex) & " " & ingredientList(0, arrayIndex)
        If sheetRow > LIST_LAST_ROW Then
            columnIndex = columnIndex + 1
            sheetRow = LIST_FIRST_ROW
            If columnIndex > LIST_LAST_COLUMN Then Exit Sub
        End If

        wsPlan.Cells(sheetRow, columnIndex) = listItem
        sheetRow = sheetRow + 1
    Next

End Sub


187
0
задан 5 февраля 2018 в 10:02 Источник Поделиться
Комментарии