meilleure boucle pour mon VBA Tâche

Question

Je suis vraiment nouveau dans le codage VBA, actuellement j'ai une feuille de calcul contient des groupes et des comptes à différents niveaux, suivant sont un exemple simple:

Groupe codes sont tous les numéros et compte codes commencent par 3 lettres, disons ABC suivi par 2 ou 3 chiffres, donc un exemple serait ABC100, les 2 premiers codes de lettre de compte sont toujours les mêmes, à savoir "AB" dans l'exemple, donc un autre le code de compte pourrait être ABS80. Les codes du groupe/compte se trouvent dans une colonne distincte correspondant aux groupes/comptes .

Mon objectif est de mettre en place une macro qui me fournirait un résumé, dans un onglet séparé appelé dire résultats, de tous les groupes (UNIQUEMENT) au-dessus d'une donnée compte/Groupe dans la hiérarchie arbre, avec le sujet compte/groupe sur le fond. Donc pour illustrer en utilisant l'exemple ci-dessus. Si le sujet compte est ABC100, puis après l'exécution de la macro, je pense voir dans les résultats onglet:

Jusqu'à présent, je réussi à obtenir la macro pour trouver la position de le sujet compte dans la hiérarchie et copiez cette ligne dans l'onglet « résultats. Mais je suis coincé à l'étape suivante qui consiste à extraire uniquement les groupes de niveau supérieur directement (en même temps ignorer les comptes & groupes entre) et les coller dans l'onglet résultats.

Je sais que j'ai besoin d'utiliser la boucle et essayé For Next avec If Then instruction entre, mais continue à recevoir des messages d'erreur. Vraiment apprécier si quelqu'un pourrait me conduire à la bonne direction sur quelle boucle à utiliser.

Merci!Voici mes codes actuels:

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

Cette traverse la hiérarchie en arrière dans « Résultats » qui est une copie complète de feuille « Tableau de bord »

• CUIRS toutes les lignes, unhides puis chaque ligne concernée, afin d'éviter les données de copier et coller

---

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 

---

Avant

Après

Answer 2

Tenir compte pas de boucle For ou If logique et il suffit d'utiliser SQL que vous pouvez dans Excel pour PC en utilisant les Jet/ACE SQL Engine (fichiers .dll de Windows). Parce que votre feuille de calcul représente une table que nous pouvons exécuter différentes logiques WHERE à la sortie de résultats onglet avec la méthode CopyFromRecordset:

SQL(embedded ci-dessous, réglez SheetName et en-têtes de colonnes au besoin)

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(se connecte à dernière instance enregistrée du classeur en cours)

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

Essayez ceci. Cela a utilisé un tableau variant.

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