Workbook Split hängt hier

Question

Das Projekt: Es handelt sich um sehr sensible HR/Performance-Daten, und ich muss Tausende von Mitarbeitern Daten an ihre einzelnen Manager senden (etwa 100 Manager, die nur die Daten ihres Teams sehen können, und niemand anderes), also brauche ich ungefähr 100 Dateien aufgeteilt (1 für jeden Manager).

Die Datei: - Viele verschiedene Registerkarten, getrennt nach Rolle. - Die erste Spalte ist ein eindeutiger Bezeichner, der durch Verketten des Managers mit dem Jobtitel ex erstellt wird. John Stevens_Office Manager

Die Aufgabe: John Stevens wird Teammitglieder in vielen verschiedenen Jobrollen haben und benötigt alle diese Daten in einer Datei, in Registerkarten nach Job-Rolle getrennt.

Auf der Grundlage dieser Beispieldaten, die ideale Makro würde mir drei Dateien mit 3 Arbeitsblätter in jedem, und 1 Datenzeile in jedem Arbeitsblatt. Ich werde mich jedoch damit begnügen, dass das Arbeitsblatt in mehrere Dateien aufgeteilt wird.

Hier ist mein Code.

Sub SplitWB() 
Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

ActiveWorkbook.Save 

Dim OutputFolderName As String 
OutputFolderName = "" 
    Set myDlg = Application.FileDialog(msoFileDialogFolderPicker) 
    myDlg.AllowMultiSelect = False 
    myDlg.Title = "Select Output Folder for Touchstone Files:" 
    If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub 
    Set myDlg = Nothing 

    Application.CutCopyMode = False 

    ''''''''''''''''''''''''''''' 
    ''''''''''''''''''''''''''''' 

    Dim d As Object, c As Range, k, tmp As String, unique(500) 
    i = 0 

    With ActiveSheet 
     lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
    End With 

    Set d = CreateObject("scripting.dictionary") 
    For Each c In Range(Cells(1, 1), Cells(lastRow, 1)) 
     tmp = Trim(c.Value) 
     If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1 
    Next c 

    For Each k In d.keys 
     Debug.Print k, d(k) 
     i = i + 1 
     unique(i) = k 
    Next k 

    UniqueCount = i 

'start deleting 

For i = 1 To UniqueCount 

    'Actions for new workbook 
    wpath = Application.ActiveWorkbook.FullName 
    wbook = ActiveWorkbook.Name 
    wsheet = ActiveSheet.Name 

    ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 

    For j = 1 To lastRow 
     If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then 
      Rows(j).Delete 
      j = j - 1 
     End If 
    Next 

    'hide helper columns 

' If HideC = False And DeleteC = True Then 
     Columns("A:D").Hidden = True 
' End If 
' 


    Range("E8").Select 


    'Select Instructions tab 
    'Worksheets("Guidelines").Activate 

    'Save new workbook 
    ActiveWorkbook.Close SaveChanges:=True 
    Workbooks.Open (wpath) 

    'ActiveWorkbook.Close False 

    Workbooks(wbook).Activate 

Next 


Application.DisplayAlerts = True 
Application.ScreenUpdating = True 

MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName) 

End Sub 

Der Code hängt bei "Wenn Range (" A "& j) <> "" Und Range ("A" & j) <> unique (i) Then"

Es liegt ca. halb in den Code und der Chunk beginnt mit "Für j = 1 bis lastRow"

Bitte helfen. Es wird mir buchstäblich einen Tag Arbeit oder mehr ersparen. Vielen Dank!!!

Answer 1

Versuchen

For j = lastRow to 1 step -1 
    If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then 
     Rows(j).Delete 
    End If 
Next 

statt. Dies ermöglicht es Ihnen, eine Schleife rückwärts zu machen, wenn Sie eine Zeile löschen, wird es nicht die Spur verlieren, wo Sie wollen j in der Schleife sein.