Question

项目：它处理非常敏感的人力资源/绩效数据，我需要派遣1000名员工和＃39;数据给他们的个人经理（大约100名经理只能看到他们的团队数据，而不是其他人），所以我需要分割大约100个文件（每个经理1个）。

文件 - 许多不同的标签，由角色分隔。 - 第一列是通过将Manager的名称与作业标题ex连接而形成的唯一标识符。 John Stevens_Office经理

任务： John Stevens将拥有许多不同工作角色的团队成员，并且需要将所有数据放在一个文件中，按作业角色分为标签。

基于该样本数据，理想的宏将为我提供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

代码挂起＆＃34;如果范围（＆＃34; A＆＃34;＆amp; j）＆lt;＆gt; ＆＃34;＆＃34;和范围（＆＃34; A＆＃34;＆amp; j）＆lt;＆gt;独特的（i）然后＆＃34;

它位于代码的大约一半，而块以＆＃34开头;对于j = 1到lastRow＆＃34;

请帮忙。它实际上可以节省我一天或更多的工作。感谢!!!

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在循环中的位置。

工作簿拆分在这里挂起

1 个答案: