Excel Arbeitsblatt Split

Question

Also brauche ich ein wenig Hilfe mit einem vorhandenen Makro.

Ich muss mehrere Arbeitsblätter einer Arbeitsmappe in mehrere Dateien aufteilen (nicht auf Arbeitsblattname basiert).

Das Projekt: Es handelt sich um sehr sensible HR/Leistungsdaten, und ich muss 1000s Mitarbeiterdaten an ihre individuellen Manager senden (etwa 100 Manager, die nur die Daten ihres Teams sehen können, und keine anderen) , 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. Mein aktuelles Makro macht die Hälfte davon (teilt die Datei auf, vereinigt sich aber nicht).

Es löscht auch nicht die anderen Registerkarten aus der Datei ... und es ist eine große Datei mit etwa 50 Registerkarten. Sogar einige Hilfe beim Löschen der anderen Tabs würde sehr geschätzt werden. Außerdem werden die Daten über VLookup aufgefüllt, und jedes Mal, wenn eine Datei geteilt wird, wird eine Nachricht angezeigt, in der ich gefragt werde, ob ich die Links aktualisieren möchte. Können die Updates dauerhaft aktiviert werden, sodass sie sich ohne manuelle Eingabe aufteilen?

Unten finden Sie einige Beispieldaten. Bitte beachten Sie, dass die tatsächliche Datei weitaus komplexe (mindestens 50 Spalten) ist

Sample Data

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 

Thank you! Ich wünsche ihnen einen wunderbaren Tag!

Answer 1

Teilweise Antwort: Setzen Sie dies an der Spitze Ihres Codes: application.AskToUpdateLinks = False und dies am Ende application.AskToUpdateLinks = true.

Answer 2

Also ich denke, Sie haben eine Menge zusätzlichen Code, der möglicherweise nicht benötigt wird. Ich werde anfangen, kleine B/C Ich bin mir nicht sicher, ob ich die Aufgabe vollständig verstehe.

Erstens, ich werde ein Array für alle Namen in der Spalte A. Weiter zu schaffen, ich werde durch das Array iterieren nur für die einzigartigen Werte

Sub SplitWB() 
    Dim namesArray As Variant 
    Dim uniqueDict As New dictionary 

    namesArray = Range("a1:a4") 'hardcoded the range for now 
    Set uniqueDict = New dictionary 

    For x = LBound(namesArray) To UBound(namesArray) 
     If Not uniqueDict.Exists(x) Then uniqueDict.Add x, namesArray (x, 1) 
    Next x 
End Sub 

Die oben kann nichts tun, für Sie gerade noch, aber ich merke, dass Sie einzigartige für Schleifen, etc, die nicht notwendig sind. Versuchen Sie einfach, Ihren Code zu komprimieren, um das Debuggen zu vereinfachen.

Sobald Sie darauf reagieren, können wir auf den nächsten Teil der Arbeit (Sie Ihren Code aktualisieren möchten, wenn Sie über meine Lösung verwenden, um ein einzigartiges Wörterbuch erstellen)