VBA Advanced AutoFilter + Créer de nouvelles feuilles en fonction de la plage

Question

Je dois créer de nouveaux onglets dans un classeur en fonction d'une plage de cellules dans un modèle de feuille de calcul. Je souhaite également supprimer les lignes de données qui ne correspondent pas au nom de l'onglet. Par exemple, dans le tableau ci-dessous, j'aurais un nouvel onglet nommé "2206 - 6" et seules les données associées resteraient, en gardant à l'esprit que cette plage de données changera chaque fois que la macro est utilisée.

Avant:

Après:

---

Intervalle Nombre 2206-6 6304-5 4102 - 20

La table commence à la ligne 11, mais je dois conserver toutes les informations ci-dessus. J'ai un filtre avancé Macro qui se rapproche de ce que je veux, mais ce fait deux choses que je ne veux pas: créer des onglets vides et non conserver les informations ci-dessus la ligne 11.

Sub parse_data() 
    Dim lr As Long 
    Dim ws As Worksheet 
    Dim vcol, i As Integer 
    Dim icol As Long 
    Dim myarr As Variant 
    Dim title As String 
    Dim titlerow As Integer 

    vcol = 1 
    Set ws = Sheets("Offshore Searches") 
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
    title = "A11:G20" 
    titlerow = ws.Range(title).Cells(1).Row 
    icol = ws.Columns.Count 
    ws.Cells(1, icol) = "Unique" 

    For i = 2 To lr 
     On Error Resume Next 
     If ws.Cells(i, vcol) <> "" And _ 
      Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
      ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
     End If 
    Next 

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
    ws.Columns(icol).Clear 

    For i = 2 To UBound(myarr) 
     ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
     If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
      Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
     Else 
      Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
     End If 
     ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
     Sheets(myarr(i) & "").Columns.AutoFit 
    Next 
    ws.AutoFilterMode = False 
    ws.Activate 
End Sub 

J'ai aussi une macro qui crée onglets basés sur une gamme sans le filtre avancé, de sorte que chaque onglet semble identique (seulement les changements de nom de l'onglet)

Sub CreateWorkSheetByRange() 
    Dim WorkRng As Range 
    Dim ws As Worksheet 
    Dim arr As Variant 

    On Error Resume Next 

    Set WorkRng = Application.Selection 
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8) 
    arr = WorkRng.Value 
    Sheets("Offshore Searches").Select 
     Cells.Select 
     Selection.Copy 
    Application.ScreenUpdating = False 

    For i = 1 To UBound(arr, 1) 
     For j = 1 To UBound(arr, 2) 
      Set ws = Worksheets.Add(after:=Application.ActiveSheet) 
      ws.Name = arr(i, j) 
      ActiveSheet.Paste 
      Range("A1").Select 
     Next 
    Next 
    Application.ScreenUpdating = True 
End Sub 

Est-il possible à la fois créer des onglets sur la base d'une gamme tout en utilisant un filtre avancé?

Answer 1

Une autre option (testé)

Toutes les fonctions ci-dessous, dans un module séparé
Il copie la feuille principale, supprime le bouton et utilise le filtre automatique pour supprimer les lignes inutiles

---

Ceci utilise des dictionnaires et la liaison tardive est lente: CreateObject ("Scripting.Dictionnaire ")

liaison précoce est rapide: éditeur VBA ->Outils ->Références -> Ajouter Microsoft Scripting Runtime

---

Option Explicit 

Private Const X As String = vbNullString 
Public Sub CreateTabs() 
    Const FIRST_CELL As String = "Interval Number" 
    Const LAST_CELL  As String = "Vesting Doc Number (LC/RS)" 
    Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, d As Dictionary, i As Long 
    Dim fr As Long, lr As Long, fc As Long, found As Range, rng As Range, val As String 

    SetDisplay False 
    Set wb = ThisWorkbook 
    Set ws = wb.Worksheets("Offshore Searches") 
    Set found = FindCell(ws.UsedRange, FIRST_CELL) 
    If Not found Is Nothing Then 
     fr = found.Row + 1 
     fc = found.Column 
    End If 
    Set found = FindCell(ws.UsedRange, LAST_CELL) 
    If Not found Is Nothing Then lr = found.Row - 1 

    If fr > 0 And fc > 0 And lr >= fr Then 
     If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter 
     Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc)) 
     Dim arr As Variant, r As Long 
     arr = rng 
     Set d = New Dictionary 
     For r = 1 To UBound(arr) 
      val = Trim(CStr(arr(r, 1))) 
      val = CleanWsName(val) 
      If Not d.Exists(val) Then d.Add r, val 
     Next 
     For i = 1 To d.Count 
      If Not WsExists(d(i)) Then 
      ws.Copy After:=wb.Worksheets(wb.Worksheets.Count) 
      Set wsNew = wb.Worksheets(wb.Worksheets.Count) 
      With wsNew 
      .Name = d(i): If .Shapes.Count = 1 Then wsNew.Shapes.Item(1).Delete 
      Set rng = .Range(.Cells(fr - 1, fc), .Cells(lr, fc)) 
     rng.AutoFilter Field:=1, Criteria1:="<>" & d(i), Operator:=xlAnd, Criteria2:="<>" 
      Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1) 
      rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp 
      rng.AutoFilter 
      End With 
      End If 
     Next 
    End If 
    ws.Activate 
    SetDisplay True 
End Sub 

---

Public Sub SetDisplay(Optional ByVal status As Boolean = False) 
    Application.ScreenUpdating = status 
    Application.DisplayAlerts = status 
End Sub 

Public Function FindCell(ByRef rng As Range, ByVal celVal As String) As Range 
    Dim found As Range 
    If Not rng Is Nothing Then 
     If Len(celVal) > 0 Then 
      Set found = rng.Find(celVal, MatchCase:=True) 
      If Not found Is Nothing Then Set FindCell = found 
     End If 
    End If 
End Function 

Public Function CleanWsName(ByVal wsName As String) As String 
    Const x = vbNullString 
    wsName = Trim$(wsName) 'Trim, then remove [ ]/\ < > : * ? | " 
    wsName = Replace(Replace(Replace(wsName, "[", x), "]", x), " ", x) 
    wsName = Replace(Replace(Replace(wsName, "/", x), "\", x), ":", x) 
    wsName = Replace(Replace(Replace(wsName, "<", x), ">", x), "*", x) 
    wsName = Replace(Replace(Replace(wsName, "?", x), "|", x), Chr(34), x) 
    If Len(wsName) = 0 Then wsName = "DT " & Format(Now, "yyyy-mm-dd hh.mm.ss") 
    CleanWsName = Left$(wsName, 31)   'Resize to max len of 31 
End Function 

Public Function WsExists(ByVal wsName As String) As Boolean 
    Dim ws As Worksheet 
    With ThisWorkbook 
     For Each ws In .Worksheets 
      If ws.Name = wsName Then 
       WsExists = True 
       Exit Function 
      End If 
     Next 
    End With 
End Function 

---

hypothèses

• Format Nombres d'intervalle est compatible: Unité & "-" & semaine (= B12 & "-" & C12)
• Nombres d'intervalle ne sont pas plus de 31 caractères, et n » t contiennent ces caractères spéciaux: []/\? *.
  • Si oui, les noms de feuille seront raccourcies à 31 caractères
  • et tous les caractères spéciaux mentionnés Suppressions (limitation Excel pour les noms de feuilles)
• ligne de travail commence après la cellule « Intervalle Nombre » et d'arrêt avant "Vesting Doc Number (LC/RS)"
• Il n'y a aucun espace avant ou après "Interval Number" et "Vesting Doc Number (LC/RS)"
• Le nom de l'onglet principal est exactement "Recherches offshore", et il ne contient qu'un seul bouton ("Créer des onglets")

Answer 2

Pour ce que vous avez montré dans les images, vous pouvez essayer quelque chose comme ça pour y parvenir ...

Sub InsertSheets() 
Dim sws As Worksheet, ws As Worksheet 
Dim slr As Long, i As Long 
Dim Rng As Range, Cell As Range 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Set sws = Sheets("Sheet1") 
If sws.Range("A12").Value = "" Then 
    MsgBox "No Interval Numbers found on the sheet.", vbExclamation 
    Exit Sub 
End If 
slr = sws.Range("A11").End(xlDown).Row 
Set Rng = sws.Range("A12:A" & slr) 
For Each Cell In Rng 
    On Error Resume Next 
    Sheets(Cell.Value).Delete 
    On Error GoTo 0 
    sws.Copy after:=Sheets(Sheets.Count) 
    Set ws = ActiveSheet 
    ws.Name = Cell.Value 
    ws.DrawingObjects.Delete 
    With ws 
     For i = slr To 12 Step -1 
      If i <> Cell.Row Then ws.Rows(i).Delete 
     Next i 
    End With 
    Set ws = Nothing 
Next Cell 
sws.Activate 
Application.DisplayAlerts = True 
Application.ScreenUpdating = True 
End Sub