Diviser le classeur en plusieurs classeurs basés sur deux colonnes

Question

J'espère que tout le monde va bien.

Je cherche de l'aide. Je cherche à automatiser un classeur qui sépare les données du fichier principal aux classeurs individuels basés sur la colonne H. Ce qui doit être fait en premier est que la colonne T doit être filtrée à 'Possédé' ou 'Impacté'. La colonne H doit ensuite être divisée en deux classeurs distincts. en fonction de ce qui peut être dans la colonne H. Sur chaque nouveau classeur créé, tout ce qui est sous la colonne H doit comporter deux onglets, un onglet pour 'Possédé' et un autre pour 'Impacté'. Cela devrait être sauvegardé alors quel que soit le nom de la cellule et la date. Le bit difficile supplémentaire se trouve dans la colonne H, dans chaque cellule, il peut y avoir des cellules individuelles A, B, C, D, E, F, mais il peut également y avoir des cellules avec plusieurs lettres. S'ils ont plusieurs lettres, chacun doit aller dans tous les classeurs mentionnés dans la cellule. Donc, par exemple s'il y a une cellule avec A, B, C, D, cela voudrait dire qu'il faudrait aller dans le classeur pour les classeurs individuels pour A, B, C et D.

J'ai joint l'image du fichier et j'ai le code ci-dessous que j'ai utilisé. Cela fonctionne, cependant en raison du problème ci-dessus avec les critères multiples dans les cellules, il divise les classeurs plus loin dans des classeurs individuels. Est-ce que quelqu'un sait si une liste déroulante peut être ajoutée où je peux sélectionner les critères de la colonne H et T, ou un autre travail autour s'il vous plaît. Je suis heureux d'essayer un autre code si nécessaire. Exemple de classeur joint également.

Option Explicit 

Sub ParseItems() 
'Based on selected column, data is filtered to individual workbooks 
'workbooks are named for the value plus today's date 
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long 
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String 

'Sheet with data in it 
Set ws = Sheets("Master") 

'Path to save files into, remember the final \ 
SvPath = "\\My Documents\New folder\" 

'Range where titles are across top of data, as string, data MUST 
'have titles in this row, edit to suit your titles locale 
vTitles = "A1:V1" 

'Choose column to evaluate from, column A = 1, B = 2, etc. 
vCol = Application.InputBox("What column to split data by? " & vbLf _ 
    & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 8, Type:=1) 
    If vCol = 0 Then Exit Sub 

'Spot bottom row of data 
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row 

'Speed up macro execution 
Application.ScreenUpdating = False 

'Get a temporary list of unique values from key column 
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, 
CopyToRange:=ws.Range("HH1"), Unique:=True 

'Sort the temporary list 
ws.Columns("HH:HH").Sort Key1:=ws.Range("HH2"), Order1:=xlAscending, 
Header:=xlYes, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, 
DataOption1:=xlSortNormal 

'Put list into an array for looping (values cannot be the result of 
formulas, must be constants) 
MyArr = Application.WorksheetFunction.Transpose(ws.Range("HH2:HH" & 
Rows.Count).SpecialCells(xlCellTypeConstants)) 

'clear temporary worksheet list 
ws.Range("HH:HH").Clear 

'Turn on the autofilter, one column only is all that is needed 
ws.Range(vTitles).AutoFilter 

'Loop through list one value at a time 
For Itm = 1 To UBound(MyArr) 
    ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) 

    ws.Range("A1:A" & LR).EntireRow.Copy 
    Workbooks.Add 
    Range("A1").PasteSpecial xlPasteAll 
    Cells.Columns.AutoFit 
    MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1 

    ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & 
    ".xlsx", 51 'use for Excel 2007+ 
    ActiveWorkbook.Close False 

    ws.Range(vTitles).AutoFilter Field:=vCol 
    Next Itm 

'Cleanup 
ws.AutoFilterMode = False 
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: 
" & MyCount & vbLf & "Hope they match!!" 
Application.ScreenUpdating = True 
End Sub 

Toute aide serait appréciée. Merci d'avance

Answer 1

Plutôt que d'appliquer des filtres à la feuille de calcul, vous pouvez charger l'ensemble de données dans un tableau, puis stocker les numéros d'index de ligne pour chacun des différents critères. Vous pouvez ensuite utiliser les listes d'index de lignes pour découper le tableau pour chaque sortie respective.

Je n'ai pas vos données sources (je n'ai pas pu voir le fichier joint) mais cette approche fonctionnerait-elle?

Sub VariableCollections() 

Dim HeaderVals() As Variant 
Dim SourceData() As Variant, Criteria As Variant 
Dim RowIndexLists As New Collection, ColIndexList As String 
Dim KeyStore As New Collection, Key As Variant 
Dim i As Long, Temp As String 
Dim fName As String, fFormat As Long 
Dim OutputArr() As Variant 

On Error GoTo ErrorHandler 
Application.ScreenUpdating = False 

With Sheets("Master") 'change if necessary 

    'store table header values in array (A1:W1) 
    HeaderVals = .Cells(1, 1).Resize(, 23).Value 

    'store data in array, assume starts at A2 
    SourceData = .Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 23).Value 

End With 

'index row #s for each Criteria & Owned/Impacted 
For i = LBound(SourceData, 1) To UBound(SourceData, 1) 

    If SourceData(i, 23) = "Owned" Then 'col W 

     'loop each Criteria (col H) for current row 
     For Each Criteria In Split(SourceData(i, 8), ", ") 

      'test if key already added to KeyStore 
      If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria 

      'test if Criteria already added to RowIndexLists 
      If InCollection(RowIndexLists, Criteria & "_Own") Then 'already added... 

       '...update row index value for current key 
       Temp = RowIndexLists(Criteria & "_Own") 
       RowIndexLists.Remove (Criteria & "_Own") 
       RowIndexLists.Add Temp & "," & i, Criteria & "_Own" 

      Else 'not already stored... 

       '...Create New Item 
       RowIndexLists.Add i, Criteria & "_Own" 

      End If 

     Next Criteria 

    ElseIf SourceData(i, 23) = "Impacted" Then 'col W 

     'loop each Criteria (col H) for current row 
     For Each Criteria In Split(SourceData(i, 8), ", ") 

      'test if key already added to KeyStore 
      If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria 

      'test if Criteria already added to RowIndexLists 
      If InCollection(RowIndexLists, Criteria & "_Imp") Then 'already added... 

       '...update row index value for current key 
       Temp = RowIndexLists(Criteria & "_Imp") 
       RowIndexLists.Remove (Criteria & "_Imp") 
       RowIndexLists.Add Temp & "," & i, Criteria & "_Imp" 

      Else 'not already stored... 

       '...Create New Item 
       RowIndexLists.Add i, Criteria & "_Imp" 

      End If 

     Next Criteria 

    End If 

Next i 

'save in same directory as current workbook 
fName = Split(ThisWorkbook.FullName, ".")(0) 

'set file format # based on OS type 
#If Mac Then 
    fFormat = 52 
#Else 
    fFormat = 51 
#End If 

'assumes cols 8 (H) and 23 (W) are no longer needed in output 
ColIndexList = "1,2,3,4,5,6,7,9,10,11,12,13,14,15,16,17,18,19,20,21,22" 

'slice HeaderVals array for matching cols 
HeaderVals = Application.Index(HeaderVals, 0, Split(ColIndexList, ",")) 

'write out to new workbooks 
For Each Key In KeyStore 

    'create new workbook 
    With Workbooks.Add 

     'output "Owned" matches for current Criteria (key value) if exist 
     If InCollection(RowIndexLists, Key & "_Own") Then 

      'slice array to indexed rows 
      OutputArr = Application.Index(SourceData, _ 
         Application.Transpose(Split(RowIndexLists(Key & "_Own"), ",")), _ 
         Split(ColIndexList, ",")) 

      'add new worksheet, rename & output data 
      With .Worksheets.Add(After:=.Sheets(.Sheets.Count)) 

       'rename sheet 
       .Name = "Owned" 

       'test if OutputArr has 2 dimensions 
       If IsArray2D(OutputArr) Then '2D i.e. rows & cols 
        .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals 
        .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr 
       Else '1D i.e. single row 
        .Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals 
        .Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr 
       End If 

      End With 

     End If 

     'output "Impacted" matches for current Criteria (key value) if exist 
     If InCollection(RowIndexLists, Key & "_Imp") Then 

      'slice array to indexed rows 
      OutputArr = Application.Index(SourceData, _ 
         Application.Transpose(Split(RowIndexLists(Key & "_Imp"), ",")), _ 
         Split(ColIndexList, ",")) 

      'add new worksheet, rename & output data 
      With .Worksheets.Add(After:=.Sheets(.Sheets.Count)) 

       'rename sheet 
       .Name = "Impacted" 

       'test if OutputArr has 2 dimensions 
       If IsArray2D(OutputArr) Then '2D i.e. rows & cols 
        .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals 
        .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr 
       Else '1D i.e. single row 
        .Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals 
        .Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr 
       End If 

      End With 

     End If 

     'delete sheet1 
     Application.DisplayAlerts = False 
     .Sheets(1).Delete 
     Application.DisplayAlerts = True 

     'save file & close 
     .SaveAs fName & "_" & Key, fFormat 
     .Close 

    End With 

Next Key 

ErrorHandler: If Err.Number <> 0 Then MsgBox "Error # " & Err.Number & " " & Err.Description 
Application.ScreenUpdating = True 

End Sub 

comme @dwirony a suggéré qu'il utilise la fonction Split sur col H pour briser les différents critères sur chaque ligne, puis stocke la ligne # dans une collection.

Je réalise un Dictionary serait mieux adapté ici plutôt que d'utiliser Collections, mais comme les dictionnaires sont Windows seulement je préfère les éviter à moins que je sache avec certitude que le fichier ne sera jamais utilisé sur Windows. Si c'est le cas, le code ci-dessus peut être simplifié en basculant les collections sur un dictionnaire. @ Jeeped Excel crée des tableaux de base 1 lors de l'affectation directe d'un objet Range à un tableau. J'ai toujours supposé les rendre semblables à l'adressage (ROW,COL).

==== ==== Modifier 6/30

code mis à jour pour refléter les changements à la disposition des données:

• supplémentaires dans Col. plage de données
• Owned/Impacted col déplacé à Col W
• Ajusté Worksheet référence pour correspondre OP demande