Question

所以我需要一些现有宏的帮助。

我需要将工作簿的多个工作表拆分为多个文件（不基于工作表名称）。

项目：它处理非常敏感的人力资源/绩效数据，我需要将1000名员工的数据发送给他们的个别经理（大约100名只能看到他们团队数据的经理，以及没有其他人），所以我需要分割大约100个文件（每个经理1个）。

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

任务： John Stevens将拥有许多不同工作角色的团队成员，并且需要将所有数据放在一个文件中，按工作角色分隔为选项卡。我当前的宏执行了一半（拆分文件，但不联合）。

它也不会从文件中删除其他标签...而且它是一个包含大约50个标签的大文件。即使只是一些帮助删除其他选项卡将不胜感激。此外，数据通过VLookup填充，每次分割文件时，它会给我一条消息，询问我是否要更新链接？是否可以永久打开更新，以便在没有任何手动输入的情况下进行拆分？

以下是一些示例数据。请记住，实际文件要复杂得多（至少50列）

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

谢谢！祝你有美好的一天！

Answer 1

部分答案：将其放在代码的顶部：application.AskToUpdateLinks = False，最后是application.AskToUpdateLinks = true。

Answer 2

所以我认为你有很多可能不需要的额外代码。我将从小b / c开始，我不确定我完全理解手头的任务。

首先，我要为A列中的所有名称创建一个数组。接下来，我将仅针对唯一值迭代数组

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

以上可能对你没有任何帮助，但我注意到你正在为循环等做独特的事情，这是不必要的。只是尝试压缩代码以便于调试。

一旦您回复此问题，我们就可以开展下一部分工作（如果您使用上面的解决方案创建一个独特的字典，您可能需要更新代码）

Excel工作表拆分

2 个答案: