Альтернатива вложенного цикла Excel VBA

Я не являюсь опытным пользователем Excel и ОЧЕНЬ новичок в VBA. Мой единственный опыт программирования — это 2 урока C # в колледже. При этом, полегче со мной;)

Я работаю в команде, которая проверяет военные базы на предмет энергосбережения. Я пытаюсь пересмотреть рабочую книгу, которая в настоящее время используется для документирования оборудования HVAC во всех зданиях на базе. У каждого здания есть отдельный лист, названный по номеру здания. На каждом листе используется одна и та же таблица и формат.

Моим самым большим препятствием было создание страницы со спецификацией материалов, которая просматривала бы каждый лист и подсчитывала все детали, необходимые для заказа. На каждом листе может быть любая комбинация частей и количества, поэтому я решил, что лучше всего перебрать каждый элемент в главном списке и подсчитать все экземпляры на каждом листе. Таким образом, у меня получилось несколько вложенных циклов, выполнение которых требует времени с тестом всего на 9 листов. Код работает, что для меня важнее всего, но сейчас меня зацепило и я хочу узнать, как сделать его лучше. Я взял книгу по VBA и планирую изучить массивы и то, как они могут помочь. Я просто хотел посмотреть, может ли кто-нибудь дать мне несколько советов, основанных на том, что у меня есть сейчас.

    Private Sub GenerateBOM_Click()
'generating a bill of materials with data from templated tables on separate sheets. Part order and quantity can change on each sheet. Sheets are named after
'building numbers which could include letters so couldn't find a better way of excluding the summary and data sheets. Wanted to allow for slight table
'structure changes so attempted to locate everything by names.

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim wsBOM As Worksheet
    Dim tblBOM As ListObject
    Dim row As range
    Dim searchRow As range
    Dim rowCount As Long
    Dim partCount As Long
    Dim totalCount As Long
    Dim partQty As Long
    
    Set wsBOM = Worksheets("Bill of Materials")
    Set tblBOM = wsBOM.ListObjects("BOM")
    Application.ScreenUpdating = False
    
        For Each row In tblBOM.ListColumns("Part Number").DataBodyRange.Rows
            rowCount = row.row - tblBOM.HeaderRowRange.row  'getting index of the row being searched. Tried to use ListRow but couldn't figure it out with the overall search
            totalCount = 0
   
            For Each ws In ThisWorkbook.Worksheets  'Loop through all sheets in a workbook
            
                If ws.Name <> "Cover" And ws.Name <> "Building List" And ws.Name <> "Data" And ws.Name <> "Building Template" And ws.Name <> "Parts" And ws.Name <> "Bill of Materials" Then
                
                    For Each tbl In ws.ListObjects  'Loop through all table on a sheet
                    
                        For Each searchRow In tbl.ListColumns("Part Number").DataBodyRange.Rows 'Loop through all part number rows on table
                            partQty = 0
                            partQty = tbl.ListColumns("Qty").DataBodyRange(searchRow.row - tbl.HeaderRowRange.row)  'getting index of the row being searched to find per sheet part qty
                            partCount = (Application.WorksheetFunction.CountIf(searchRow, row) * partQty)
                            totalCount = totalCount + partCount
                            tblBOM.ListColumns("Project Totals").DataBodyRange.Cells(rowCount).Value = totalCount   'writing total to bill of materials sheet at index of searched part number
       
                        Next searchRow
                    Next tbl
                End If
            Next ws
        Next row
    Application.ScreenUpdating = True
End Sub

VBA SumIf в столбцах нескольких таблиц

Option Explicit

Sub GenerateBOM()
    
    Const dName As String = "Bill of Materials"
    Const dtblName As String = "BOM"
    Const dlName As String = "Part Number"
    Const drName As String = "Project Totals"
    
    Const slName As String = "Part Number"
    Const srName As String = "Qty"
    
    Const ExceptionsList As String _
        = "Cover,Building List,Data,Building Template,Parts,Bill of Materials"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
     
    ' Write the names of the worksheets to be 'processed' to an array.
    Dim swsNames As Variant ' Source Worksheet Names Array
    swsNames = ArrWorksheetNames(wb, ExceptionsList)
    If IsEmpty(swsNames) Then Exit Sub
    
    ' Write the values from the Destination Lookup Range to the Data Array.
    Dim dws As Worksheet ' Destination Worksheet
    Set dws = wb.Worksheets(dName)
    Dim dtbl As ListObject ' Destination Table
    Set dtbl = dws.ListObjects(dtblName)
    Dim dlrg As Range ' Destination Lookup Column Range
    Set dlrg = dtbl.ListColumns(dlName).DataBodyRange
    Dim Data As Variant ' Data Array
    Data = GetColumnRange(dlrg)
    
    Dim sws As Worksheet ' Source Worksheet
    Dim stbl As ListObject ' Source Table
    Dim slrg As Range ' Source Lookup Column Range
    Dim ssrg As Range ' Source Sum Column Range
    
    Dim r As Long ' Data Array Row Counter
    Dim PartCount As Long ' Part Counter
    Dim TotalCount As Long ' Total Counter
    
    ' The Loops
    ' The same array is used for the 'lookups' and the results (totals).
    For r = 1 To UBound(Data, 1)
        TotalCount = 0
        For Each sws In wb.Worksheets(swsNames)
            For Each stbl In sws.ListObjects
                Set slrg = stbl.ListColumns(slName).DataBodyRange
                Set ssrg = stbl.ListColumns(srName).DataBodyRange
                PartCount = Application.SumIf(slrg, Data(r, 1), ssrg)
                TotalCount = TotalCount + PartCount
            Next stbl
        Next sws
        Data(r, 1) = TotalCount
    Next r
    
    ' Write the values from the Data Array
    ' to the Destination Result Column Range.
    Dim drrg As Range ' Destination Result Column Range
    Set drrg = dtbl.ListColumns(drName).DataBodyRange
    drrg.Value = Data
    
    MsgBox "BOM succesfully generated.", vbInformation, "Generate BOM"

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the names of the worksheets of a workbook,
'               that are not listed, in a 1D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrWorksheetNames( _
    ByVal wb As Workbook, _
    Optional ByVal ExceptionsList As String = "", _
    Optional ByVal ListDelimiter As String = ",") _
As Variant
    
    If wb Is Nothing Then Exit Function
    
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    If wsCount = 0 Then Exit Function ' no worksheet
    
    Dim Arr() As String: ReDim Arr(1 To wsCount)
    
    Dim sws As Worksheet
    Dim n As Long
    
    If Len(ExceptionsList) = 0 Then
        
        For Each sws In wb.Worksheets
            n = n + 1
            Arr(n) = sws.Name
        Next sws
    
    Else
        
        Dim Exceptions() As String
        Exceptions = Split(ExceptionsList, ListDelimiter)
        
        Dim wsName As String
        
        For Each sws In wb.Worksheets
            wsName = sws.Name
            If IsError(Application.Match(wsName, Exceptions, 0)) Then
                n = n + 1
                Arr(n) = wsName
            End If
        Next sws
        
        If n = 0 Then Exit Function ' no worksheet that's not in the list
    
        If n < wsCount Then
            ReDim Preserve Arr(1 To n)
        End If
    
    End If
    
    ArrWorksheetNames = Arr
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of the first column of a range
'               in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
    ByVal rg As Range) _
As Variant
    
    If rg Is Nothing Then Exit Function
    
    Dim cData As Variant
    With rg.Columns(1)
        Dim rCount As Long: rCount = rg.Rows.Count
        If rCount = 1 Then ' one cell
            ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
        Else
            cData = .Value ' multiple cells
        End If
    End With
    
    GetColumnRange = cData

End Function

Используйте описательные имена переменных: При выборе имен переменных всегда избегайте зарезервированных слов. Заблуждайтесь на стороне многословия. Например: не используйте имя row для переменной, поскольку это имя используемого вами свойства. Это то, что заставляет ряд tblBOM.HeaderRowRange.row в нижнем регистре. Это также приводит к запутанному утверждению row.row

Переместите декларацию ближе к использованию: Я думаю, что это упрощает отслеживание переменных, чтобы объявлять их прямо перед первым использованием. Это уводит нас от большого блока переменных вверху, которым может быть трудно управлять.

Используйте обработчик ошибок, чтобы гарантировать выполнение вашего финального кода: В данном случае я говорю о том, чтобы Application.ScreenUpdating = True всегда бежит. У вас будут плохие времена, если вы оставите его случайно.

Используйте коллекцию, чтобы выполнить фильтрацию листа только один раз: Если мы собираем все листы, которые хотим сначала просмотреть, нам не нужно фильтровать их каждый раз в цикле.

Переместите свое задание общего подсчета на самый высокий уровень: Вы устанавливаете общую сумму проекта для каждой итерации самого глубокого уровня. Я считаю, что вам нужно установить его только один раз.

Option Explicit

Private Sub GenerateBOM_Click()
    'generating a bill of materials with data from templated tables on separate sheets. Part order and quantity can change on each sheet. Sheets are named after
    'building numbers which could include letters so couldn't find a better way of excluding the summary and data sheets. Wanted to allow for slight table
    'structure changes so attempted to locate everything by names.
    On Error GoTo errorHandler

    Dim tblBOM As ListObject
    With ActiveWorkbook.Worksheets("Bill of Materials")
        Set tblBOM = .ListObjects("BOM")
    End With

    Application.ScreenUpdating = False

    Dim usedWorksheets As New Collection
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Cover" And ws.Name <> "Building List" And ws.Name <> "Data" And ws.Name <> "Building Template" And ws.Name <> "Parts" And ws.Name <> "Bill of Materials" Then
            usedWorksheets.Add ws
        End If
    Next ws

    Dim BOMpartRow As Range
    For Each BOMpartRow In tblBOM.ListColumns("Part Number").DataBodyRange.Rows
        Dim rowCount As Long
        rowCount = BOMpartRow.Row - tblBOM.HeaderRowRange.Row 'getting index of the row being searched. Tried to use ListRow but couldn't figure it out with the overall search
    
        Dim totalCount As Long
        totalCount = 0

        For Each ws In usedWorksheets            'Loop through all sheets in a workbook
            Dim tbl As ListObject
            For Each tbl In ws.ListObjects       'Loop through all table on a sheet
                Dim searchRow As Range
                For Each searchRow In tbl.ListColumns("Part Number").DataBodyRange.Rows 'Loop through all part number rows on table
                    Dim partQty As Long
                    partQty = tbl.ListColumns("Qty").DataBodyRange(searchRow.Row - tbl.HeaderRowRange.Row) 'getting index of the row being searched to find per sheet part qty
                    Dim partCount As Long
                    partCount = (Application.WorksheetFunction.CountIf(searchRow, BOMpartRow) * partQty)
                    totalCount = totalCount + partCount
                Next searchRow
            Next tbl
        Next ws
    
        tblBOM.ListColumns("Project Totals").DataBodyRange.Cells(rowCount).Value = totalCount 'writing total to bill of materials sheet at index of searched part number
    Next BOMpartRow

errorHandler:
    Application.ScreenUpdating = True
End Sub

Я согласен с комментариями / ответом, предоставленными @HackSlash, и использовал версию подпрограммы @HackSlash в этом ответе. И версия @ VBasic2008, безусловно, также является улучшением и демонстрирует более эффективную реализацию при снижении уровней вложенности с 4 до 3. Тем не менее, исходное название сообщения подразумевает интерес к альтернативам вложенным циклам.

Итак, FWIW, касательно удаления / сокращения вложенных циклов:

Чтобы уменьшить количество вложенных уровней, одна из стратегий состоит в том, чтобы преобразовать некоторые или все циклы в функцию или подпрограмму с параметрами, основанными на данных / объектах, распространяемых с уровня вложенности на уровень вложенности. Результатом является код с набором небольших вспомогательных функций, каждая из которых предназначена для достижения целей уровня вложенности. Как правило, это улучшает читаемость и, при необходимости, может быть протестировано независимо.

В этом случае в приведенном ниже примере был преобразован почти весь код в новый стандартный модуль. GenerateBOMSupport. Код, оставшийся в оригинале UserForm содержит проблемы, связанные с пользовательским интерфейсом, для обработки CommandButton событие щелчка и управление Application.ScreenUpdating флаг. Такое разделение задач согласуется с передовой практикой использования только кода, связанного с пользовательским интерфейсом / элементами управления, в UserForm код программной части.

    'UserForm code-behind
    Option Explicit

    Private Sub GenerateBOM_Click()
        'generating a bill of materials with data from templated tables on separate sheets. Part order and quantity can change on each sheet. Sheets are named after
        'building numbers which could include letters so couldn't find a better way of excluding the summary and data sheets. Wanted to allow for slight table
        'structure changes so attempted to locate everything by names.
        On Error GoTo errorHandler

        Application.ScreenUpdating = False
        
        Dim usedWorksheets As Collection
        Set usedWorksheets = GenerateBOMSupport.DetermineUsedWorksheets(ThisWorkbook)
        
        Dim bomWorksheet as Worksheet
        Set bomWorkSheet = ActiveWorkbook.Worksheets(GenerateBOMSupport.BOMWorksheetName)
        
        GenerateBOMSupport.UpdateBOMTotalCount bomWorkSheet, usedWorksheets
        
    errorHandler:
        Application.ScreenUpdating = True
    End Sub

И вспомогательный модуль. UpdateBOMTotalCount имеет единственный вложенный цикл, в противном случае вложенные циклы были реорганизованы.

    'Standard Module: GenerateBOMSupport          
    Option Explicit
    
    Public Const BOMWorksheetName As String = "Bill of Materials"

    Public Function DetermineUsedWorksheets(ByVal theWorkbook As Workbook) As Collection
        Set DetermineUsedWorksheets = New Collection
        
        Dim ws As Worksheet
        For Each ws In theWorkbook.Worksheets
            If ws.Name <> "Cover" And ws.Name <> "Building List" And ws.Name <> "Data" And ws.Name <> "Building Template" And ws.Name <> "Parts" And ws.Name <> "Bill of Materials" Then
                DetermineUsedWorksheets.Add ws
            End If
        Next ws

    End Function

    Public Sub UpdateBOMTotalCount(ByVal bomWorksheet As Worksheet, ByVal usedWorksheets As Collection)

        Dim tblBOM As ListObject
        Set tblBOM = bomWorksheet.ListObjects("BOM")

        Dim BOMpartRow As Range
        For Each BOMpartRow In tblBOM.ListColumns("Part Number").DataBodyRange.Rows
            Dim rowCount As Long
            rowCount = BOMpartRow.Row - tblBOM.HeaderRowRange.Row 'getting index of the row being searched. Tried to use ListRow but couldn't figure it out with the overall search
        
            Dim totalCount As Long
            totalCount = 0
                    
            Dim ws As Worksheet
            For Each ws In usedWorksheets            'Loop through all sheets in a workbook
                totalCount = UpdateTotalCountFromWorksheet(ws, BOMpartRow, totalCount)
            Next ws
        
            tblBOM.ListColumns("Project Totals").DataBodyRange.Cells(rowCount).Value = totalCount 'writing total to bill of materials sheet at index of searched part number
        Next BOMpartRow
    End Sub

    Private Function UpdateTotalCountFromWorksheet(ws As Worksheet, ByVal BOMpartRow As Range, ByVal totalCount As Long) As Long
        
        UpdateTotalCountFromWorksheet = totalCount
        Dim tbl As ListObject
        For Each tbl In ws.ListObjects
            UpdateTotalCountFromWorksheet = UpdateTotalCountFromListObject(tbl, BOMpartRow, UpdateTotalCountFromWorksheet)
        Next tbl
    End Function

    Private Function UpdateTotalCountFromListObject(tbl As ListObject, ByVal BOMpartRow As Range, ByVal totalCount As Long) As Long
        UpdateTotalCountFromListObject = totalCount
        
        Dim searchRow As Range
        For Each searchRow In tbl.ListColumns("Part Number").DataBodyRange.Rows 'Loop through all part number rows on table
            Dim partQty As Long
            partQty = tbl.ListColumns("Qty").DataBodyRange(searchRow.Row - tbl.HeaderRowRange.Row) 'getting index of the row being searched to find per sheet part qty
            
            Dim partCount As Long
            partCount = (Application.WorksheetFunction.CountIf(searchRow, BOMpartRow) * partQty)
            
            UpdateTotalCountFromListObject = UpdateTotalCountFromListObject + partCount
        Next searchRow
        
    End Function

Конечно, перемещение вложенного цикла в выделенную функцию не улучшит скорость или эффективность. Однако многократно вложенные циклы сложнее мысленно проанализировать и понять, когда приходит время модифицировать код. Кроме того, уменьшение уровней вложенности с помощью функций заставляет анализ данных / объектов, передаваемых с уровня вложенности на уровень вложенности, часто упрощая выявление неэффективности и другие возможности для улучшения кода.