Excel工作表拆分
所以我需要一个现有的macros的帮助。
我需要将工作簿的多个工作表分成多个文件（而不是基于工作表名称）。
该项目：处理非常敏感的人力资源/绩效数据，我需要发送1000个员工的数据给他们的个人经理（大约100个经理只能看到他们的团队的数据，没有其他人），所以我需要大约100文件拆分（每个pipe理器1个）。
该文件： – 许多不同的标签，由angular色分隔。 – 第一列是经理姓名和职务名称前缀的唯一标识符。 John Stevens_Office经理
任务： John Stevens将拥有许多不同工作angular色的团队成员，并且需要一个文件中的所有数据，并按工作angular色分成多个标签。 我目前的macros做了一半（拆分文件，但不团结）。
它也不会删除文件中的其他标签…以及包含大约50个标签的大文件。 即使只是一些帮助删除其他选项卡将不胜感激。 此外，数据通过VLookup填充，每次它分裂一个文件，它给了我一个消息，询问我是否要更新链接？ 更新是否可以永久打开，以便在没有任何手动input的情况下进行分割？
以下是一些示例数据。 请记住，实际的文件要复杂得多（至less50列）
样本数据
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 谢谢！ 祝你有美好的一天！
部分答案：把这个放在你的代码的顶部： application.AskToUpdateLinks = False并在最后application.AskToUpdateLinks = true 。
所以我认为你有很多额外的代码可能不需要。 我要开始小小的B / C我不知道我完全理解手头的任务。
首先，我要为列A中的所有名称创build一个数组。接下来，我将遍历数组，以获取唯一值
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
以上可能不会为你做任何事情，但我注意到你正在做独特的循环等，这是没有必要的。 只是试图压缩你的代码，以便于debugging。
一旦你回应了，我们可以在下一部分工作（如果你使用我的解决scheme创build一个独特的字典，你可能想要更新你的代码）