Здесь разведена рабочая тетрадь

Question

Проект: Он касается очень чувствительных данных о HR/эффективности, и мне нужно отправить 1000 сотрудников данных сотрудников своим индивидуальным менеджерам (около 100 менеджеров, которые могут видеть только данные своей команды и никто другой), поэтому мне нужно около 100 разделов файлов (по 1 для каждого менеджера).

Файл: - Много разных вкладок, разделенных ролью. - Первый столбец - это уникальный идентификатор, созданный путем объединения имени Менеджера с названием работы ex. John Stevens_Office Manager

Задача: Джон Стивенс будет иметь членов команды во многих разных ролях работы и нуждается во всех этих данных в одном файле, разделенных на вкладки ролью работы.

на основе этих данных образцов, идеальный макрос даст мне 3 файла с 3 листов в каждом, и 1 строка данных в каждом листе. Тем не менее, я соглашусь на то, что рабочий лист разбит на несколько файлов.

Вот мой код.

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 

Код висит на "If Range (" A "& J) <> "" И Range ("A" & к) <> уникальный (я) Тогда"

Он расположен примерно на полпути в код, а кусок начинается с «For j = 1 To lastRow»

Пожалуйста, помогите. Это буквально спасет меня день или больше. Благодаря!!!

Answer 1

Попробуйте

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

вместо этого. Это позволяет вам перемещаться назад, поэтому, когда вы удаляете строку, она не потеряет информацию о том, где вы хотите, чтобы j находился в цикле.