VBA Advanced AutoFilter + Erstellen neuer Blätter basierend auf Bereich

Question

Ich muss neue Registerkarten in einer Arbeitsmappe basierend auf einer Reihe von Zellen in einer Arbeitsblattvorlage erstellen. Ich möchte auch Datenzeilen löschen, die nicht mit dem Tabnamen übereinstimmen. Zum Beispiel würde ich aus der Tabelle unten eine neue Registerkarte mit dem Namen "2206 - 6" haben, und nur die damit verbundenen Daten bleiben erhalten, wobei zu berücksichtigen ist, dass sich dieser Datenbereich jedes Mal ändert, wenn das Makro verwendet wird.

Vor:

Nach:

---

Interval Anzahl 2206-6 6304-5 4102 - 20

Die Tabelle beginnt in Zeile 11, aber ich muss alle oben genannten Informationen behalten. Ich habe einen erweiterte Filter-Makro, das zu nahe kommt, was ich will, aber es ist zu tun zwei Dinge, die ich nicht wollen: leer Registerkarten erstellen und keine Informationen über Zeile 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 

Ich habe auch einen Makro beibehalten, die erzeugen Reiter ohne den erweiterten Filter auf einem Bereich basiert, so dass jeder Reiter sieht identisch (nur die Registerkarte Namensänderungen)

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 

gibt es eine Möglichkeit, beide Registerkarten erstellen, basierend auf einem Bereich, während sie gleichzeitig einen erweiterten Filter verwenden?

Answer 1

Eine weitere Option (getestet)

Alle Funktionen unten, in einem separaten Modul
Es kopiert die Großschot, löscht die Taste und verwendet auto-Filter nicht benötigten Zeilen

---

zu entfernen

Dies verwendet Wörterbücher und späte Bindung ist langsam: CreateObject ("Scripting.Wörterbuch ")

frühe Bindung ist schnell: VBA-Editor ->Werkzeuge ->Referenzen -> Add 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 

Annahmen

• Interval Numbers-Format ist konsistent: Einheit & "-" & Woche (= B12 & "-" & C12)
• Interval Zahlen sind nicht länger als 31 Zeichen, und don‘ t enthalten diese speziellen Zeichen: []/\? *.
  • Wenn ja, werden die Blattnamen auf 31 Zeichen gekürzt werden
  • und alle Sonderzeichen entfernt genannten (Excel Einschränkung für Notennamen)
• Arbeits Zeile beginnt nach Zelle „Interval Number“ und stoppen vor "Vesting Doc Nummer (LC/RS)"
• Es gibt keine Leerzeichen vor oder nach "Intervallnummer" und "Vesting Doc Nummer (LC/RS)"
• Haupt Registerkarte Name ist genau "Offshore Search", und Es enthält nur eine Schaltfläche ("Create Tabs")

Answer 2

Für das, was Sie in den Bildern gezeigt haben, können Sie so etwas wie dies versuchen, das zu erreichen ...

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