最佳环路我的VBA任务

Question

我在VBA编码真的很新的，目前我有一个电子表格包含组及帐户不同层次，下面是一个简单的例子：

集团码是所有的数字和帐户代码以3个字母开头，说ABC后面跟着2或3个数字，所以一个例子是ABC100，第一个2个帐户代码字母总是相同的，即在该例子中是“AB”，所以另一个帐户代码可能是ABS80。 组/账户代码位于对应于组/账户的单独列中。

我的目标是建立一个宏这会为我提供一个总结，在被称为一个单独的标签说结果，所有组（只）以上给定帐户/的集团在层次结构树，与主题帐户/组在底部。

所以说明使用上面的例子。如果拍摄对象帐户是ABC100，然后运行宏后，我希望在结果看标签：

到目前为止，我设法宏观找到位置在层次结构中的主体帐户和复制一行到结果”标签。但是我卡上的下一步是只提取直接上级组（同时忽略账户 & 组之间）并将它们粘贴到结果选项卡中。

我知道我需要使用循环，并尝试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 

Answer 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 

---

之前

后

Answer 2

考虑没有For环或If逻辑和简单的使用SQL，你可以在Excel中使用Jet/ACE SQL Engine（视窗.dll文件）PC。因为工作表代表一个表，我们可以用CopyFromRecordset方法运行各种WHERE逻辑输出到结果标签：

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 

Answer 3

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

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