Excelワークシート分割

Question

だから、私は既存のマクロで少し助けが必要です。

ワークブックの複数のワークシートを複数のファイルに分割する必要があります（ワークシート名に基づいていない）。

プロジェクト：それは非常に敏感なHR /パフォーマンス・データを扱う、と私は彼らの個々の経営者に従業員のデータの1000を送信する必要があります（約100だけ自分のチームのデータを見ることができる経営者、そして誰も他の人の） 、私は約100ファイルの分割（各マネージャー1）が必要です。

ファイル： - ロールによって区切られた多数の異なるタブ。 - 最初の列は、Managerの名前と職種のexを連結した固有の識別子です。 John Stevens_Office Manager

タスク： John Stevensは、多くの異なる職務役割のチームメンバーを持ち、すべてのデータを1つのファイルにまとめ、職務役割別にタブに分ける必要があります。私の現在のマクロは、これの半分を行います（ファイルを分割しますが、結合しません）。

また、ファイルから他のタブを削除したり、約50個のタブを持つ大きなファイルも削除しません。他のタブを削除するだけでも大いに感謝します。また、データはVLookupによって読み込まれ、ファイルを分割するたびに、リンクを更新するかどうかを尋ねるメッセージが表示されます。更新を手動で入力せずに分割できるように、永久に有効にできますか？

以下はいくつかのサンプルデータです。ありがとう

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 

実際のファイルは、はるかに（少なくとも50列）に複雑であることに注意してください！すてきな一日を！

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 

以上は何もしないことだけのために配列を反復処理するつもりですまだあなたのために、私はあなたが必要ではないループなどのためにユニークなことをしていることに気づいています。デバッグを簡単にするためにコードを凝縮しようとしています。

あなたはこれに応えたら、我々は次の部分で作業することができ、