最佳環路我的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