我的 VBA 任务的最佳循环

Posted 2023-02-19

【中文标题】我的 VBA 任务的最佳循环

【英文标题】：Best Loop For My VBA Task

【发布时间】：2018-04-02 11:34:09

【问题描述】：

我是 VBA 编码的新手，目前我有一个包含不同级别的组和帐户的电子表格，以下是一个简单的示例：

Group 代码都是数字，Account 代码以 3 个字母开头，比如 ABC 后跟 2 或 3 个数字，例如 ABC100，前 2 个字母帐户代码始终相同，即示例中的“AB”，因此另一个帐户代码可能是 ABS80。 组/帐户代码位于与组/帐户相对应的单独列中。

我的目标是设置一个宏，它会在一个名为say results 的单独选项卡中为我提供一个摘要，上面的所有组（仅限）在层次结构树中给定Account/Group，主题Account/Group在底部。

所以用上面的例子来说明。如果主题 Account 是 ABC100，那么在运行宏之后，我希望在 results 选项卡中看到：

到目前为止，我设法让宏在层次结构中找到主题 account 的位置，并将该行复制到 results" 选项卡中。但我' m 停留在下一步，即仅提取直接上层 groups（同时忽略中间的 accounts 和 groups）并将它们粘贴到 results 选项卡中。

我知道我需要使用循环并尝试For Next 和If Then 之间的语句，但不断收到错误消息。如果有人能引导我找到正确的方向来使用哪个循环，我真的很感激。

谢谢！以下是我当前的代码：

Sub SearchRelevantAccGp()
'
' This macro finds the account or group and provides a summary of all affected groups
' within the Hierarchy

Dim searchvalue As Variant
searchvalue = Sheets("Dashboard").Range("B2")
Dim hierarchy As Integer
    Sheets("Main Tree").Select
    cells.Find(What:=searchvalue, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
hierarchy = ActiveCell.Offset(0, 5)
Dim startref As Variant
startref = "I" & ActiveCell.Row
Dim rownumber As Integer
rownumber = ActiveCell.Row

    ActiveCell.EntireRow.Select
    Selection.Copy
    Sheets("Result").Select
    Rows(hierarchy).Select
    ActiveSheet.Paste

Sheets("Main Tree").Select
Range(startref).Select
For i = rownumber To 2 Step -1
    If cells(i - 1, 9).Value - 1 = cells(i, 9).Value And cells(i - 1, 3).Value = "Group" Then
        Rows(i).Select
        Selection.Copy
        Sheets("Result").Select
        Rows(hierarchy - 1).Select
        ActiveSheet.Paste
    End If
Next i

End Sub

【参考方案1】：

这会在“结果”中向后遍历层次结构，这是工作表“仪表板”的完整副本

隐藏所有行，然后取消隐藏每个相关行，以避免复制和粘贴数据

---

Option Explicit

Public Sub ShowHierarchy()
    Dim ws As Worksheet, found As Range, r As Long, nextR As Long

    Set ws = ThisWorkbook.Worksheets("Results")
    Set found = ws.UsedRange.Columns(2).Find(What:="ABC10", LookAt:=xlWhole)
    If Not found Is Nothing Then                'ABC100 was found so we continue
        ws.UsedRange.EntireRow.Hidden = True    'hide all rows on Results sheet
        r = found.Row:  nextR = -1              'get found row, and move up to next row
        If r > 1 Then                           'make sure it wasn't found on row 1
            ws.Rows(1).Hidden = False           'unhide header row
            ws.Cells(1).Activate                'update display (scroll to top row)
            found.EntireRow.Hidden = False      'unhide found row
            Dim foundLvl As Long, nextLvl As Long, lvlRng As Range
            foundLvl = Val(found.Offset(0, 2))  'get current level from column D
            nextLvl = foundLvl                  'establish initial (minimum) level
            Application.ScreenUpdating = False  'turn off display
            While nextLvl > 1                   'loop while level is greater than 1
                Set lvlRng = found.Offset(nextR, 2)   'get next level from column D
                If Not IsError(lvlRng) Then     'check for errors (#N/A, #DIV/0!, etc)
                    nextLvl = Val(lvlRng)       'set next level
                    If nextLvl < foundLvl Then  'compare levels
                        If LCase(lvlRng.Offset(0, -3)) = "group" Then 'check Group in Col A
                            foundLvl = nextLvl  'set next minimum levele
                            lvlRng.EntireRow.Hidden = False
                        End If
                    End If
                End If
                nextR = nextR - 1               'move up to the next row, and repeat
            Wend
            Application.ScreenUpdating = True   'turn display back on
        End If
    End If
End Sub

---

之前

之后

【讨论】：

非常感谢 Paul 的解决方案。我想在这种情况下最终结果是一样的。我将尝试实现代码，看看是否能解决我的问题。

嗨，Paul，我已经测试了代码，但不幸的是它没有按预期工作。我认为出了问题的是代码定义“组”的方式。您可以在我的原始数据集中看到，如果它是 B 列中的帐户代码（ABC100），则 A 列将显示“帐户”而不是“组”，这就是您的屏幕截图中的情况。当我运行宏时，它只会取消隐藏标题行和“查找”行。此外，“查找”功能不是基于匹配整个单元格值，因此，例如，如果我要查找“ABC10”，如果帐户“ABC109”位于“ABC10”上方，则会出现帐户“ABC109”。谢谢！杰伊

我做了您提到的更改：它检查 A 列中的“组”一词，Find 函数查看整个单元格值 - 如果您搜索“ABC10”，它不会返回值“ABC109”

【参考方案2】：

试试这个。这使用了一个变体数组。

Sub test()
    Dim vDB, vR()
    Dim Ws As Worksheet, toWs As Worksheet
    Dim r As Long, i As Long, n As Long, j As Integer
    Set Ws = ActiveSheet
    Set toWs = Sheets(2)

    vDB = Ws.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    For i = 2 To r
        If InStr(vDB(i, 3), "Group Level") Or vDB(i, 1) = "ABC100" Then
            n = n + 1
            ReDim Preserve vR(1 To 4, 1 To n)
            For j = 1 To 4
                vR(j, n) = vDB(i, j)
            Next j
        End If
    Next i
    With toWs
        .UsedRange.Clear
        .Range("a1").Resize(1, 4) = Ws.Range("a1").Resize(1, 4).Value
        .Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
        .Columns.AutoFit
    End With

End Sub

【参考方案3】：

不考虑 For 循环或 If 逻辑，只需使用 SQL，您可以在 Excel for PC 中使用 Jet/ACE SQL Engine（Windows .dll 文件）。因为您的工作表代表一个表格，我们可以运行各种 WHERE 逻辑以使用 CopyFromRecordset 方法输出到 results 选项卡：

SQL （嵌入在下方，根据需要调整 SheetName 和列标题）

SELECT [Type], [Account / Group ID], [Account / Group Name], [Hierarchy Position]
FROM SheetName$
WHERE (([Type] = 'Group' AND [Account / Group Name] NOT LIKE '%dupe%')
       OR ([Account / Group ID] = 'ABC100'))
  AND ([Hierarchy Position] <= (SELECT Max([Hierarchy Position]) 
                                FROM SheetName$ sub 
                                WHERE sub.[Account / Group ID] = 'ABC100'))

VBA （连接到当前工作簿的最后保存实例）

Sub RunSQL()
    Dim conn As Object, rs As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer

    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' CONNECTION STRINGS (TWO VERSIONS -ODBC/OLEDB)
    strConnection = "DRIVER=Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb);" _
                      & "DBQ=C:\Path\To\Workbook.xlsm;"
'    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
'                       & "Data Source=C:\Path\To\Workbook.xlsm';" _
'                       & "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"

    ' OPEN DB CONNECTION
    conn.Open strConnection

    strSQL = "SELECT [Type], [Account / Group ID], [Account / Group Name], [Hierarchy Position]" _
              & " FROM SheetName$" _
              & " WHERE (([Type] = 'Group' AND [Account / Group Name] NOT LIKE '%dupe%')" _
              & "        OR ([Account / Group ID] = 'ABC100'))" _
              & "   AND ([Hierarchy Position] <= (SELECT Max([Hierarchy Position])" _
              & "                                 FROM SheetName$ sub" _
              & "                                 WHERE sub.[Account / Group ID] = 'ABC100'))"

    ' OPEN RECORDSET OF SQL RESULTS
    rs.Open strSQL, conn

    ' OUTPUT DATA TO EXISTING SHEET
     With ThisWorkbook.Worksheets("results")
          ' COLUMN HEADERS
           For i = 1 To rs.Fields.Count
               .Cells(1, i) = rs.Fields(i - 1).Name
           Next i    

          ' DATA ROWS
          .Range("A2").CopyFromRecordset rs
    End With

    rs.Close: conn.Close
    Set rs = Nothing: Set conn = Nothing
    Exit Sub

End Sub

【讨论】：

嗨 Parfait，这比我预期的要复杂得多，我想我还得再花 30 个小时研究 SQL :) 非常感谢你的帮助，我在你的 SQL 中注意到了一件事，一个的匹配规则似乎是帐户名称中没有“欺骗”。我的示例实际上只是为了说明数据层次结构，因此帐户/组名称并未反映真实的数据集。真实数据集中的帐户/组名称可以是任何东西，并且不遵循特定模式或包含某些单词。话虽这么说，SQL 还能工作吗？干杯。周杰伦

如果 Type 始终是 Group 和 Account，我认为这可能会满足您的需求。除了 dupe 和在 ABC100 上搜索之外，没有任何地方对任何名称进行硬编码。试试看。如果太复杂，也许未来的读者会发现一些用处。