特定の範囲のスプレッドシートを新しい名前の新しいブックに分割する

Question

ブックの特定されたワークシートに基づいてブックを別のブックに分割する方法を考え出しています。

例： アルファベットのすべての文字のワークシートがありました。

ワークシートAからCを「AからC」という名前の新しいワークブックに分割したいと考えています。

Dを介して、「DからI」という名前の新しいブックに移動します。

等...

私の考えは、最初のワークシートの名前があることを意志があるので、列Aの名前で新しいブックは、それが同じ数の列bからなると列になるワークシートを挿入することであろう新しいブックにコピーされます。

誰でもこのためのマクロを作成する方法はありますか？私は自分自身を試してみましたが失敗しました。

ありがとうございました！

このマクロが見つかりました。誰もそれが動作するように変更することができると思いますか？

Sub Test() 
Dim Sh As Worksheet 
Dim Rng As Range 
Dim c As Range 
Dim List As New Collection 
Dim Item As Variant 
Dim WB As Workbook 
Application.ScreenUpdating = False 

Set Sh = Worksheets("Sheet1") 
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row) 
On Error Resume Next 
For Each c In Rng 
    List.Add c.Value, CStr(c.Value) 
Next c 
On Error GoTo 0 
Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row) 
For Each Item In List 
    Set WB = Workbooks.Add 
    Rng.AutoFilter Field:=1, Criteria1:=Item 
    Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1") 
    Rng.AutoFilter 
    With WB 
     .SaveAs ThisWorkbook.Path & "\" & Item & ".xls" 
     .Close 
    End With 
Next Item 
Sh.Activate 
Application.ScreenUpdating = True 

End Subの

Answer 1

次のコードは、マクロを含むブックに（「スプリット・パラメータ」という名前の）あなたのコントロールシートを持っている、そしてそれは、列Aで目的のファイル名と一緒に設定されていると仮定して、列B、Cなどに列挙されている、そのファイルにコピーしたいシート（ActiveWorkbookから、またはマクロを含むかもしれないかもしれません）。行1は見出しであるとみなされ、したがって無視されます。

Sub SplitBook() 
    Dim lastRow As Long 
    Dim LastColumn As Long 
    Dim srcWB As Workbook 
    Dim newWB As Workbook 
    Dim i As Long 
    Dim c As Long 
    Dim XPath As String 
    Dim newName As String 
    Dim sheetName As String 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Set srcWB = ActiveWorkbook 
    XPath = srcWB.Path 
    With ThisWorkbook.Worksheets("Split Parameters") 
     lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     For i = 2 To lastRow 
      'Take the first worksheet and create a new workbook 
      sheetName = .Cells(i, "B").Value 
      srcWB.Sheets(sheetName).Copy 
      Set newWB = ActiveWorkbook 
      'Now process all the other sheets that need to go into this workbook 
      LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column 
      For c = 3 To LastColumn 
       sheetName = .Cells(i, c).Value 
       srcWB.Sheets(sheetname).Copy After:=newWB.Sheets(newWb.Sheets.Count) 
      Next 
      'Save the new workbook 
      newName = .Cells(i, "A").Value 
      newWB.SaveAs Filename:=xPath & "\" & newName & ".xls", FileFormat:=xlExcel8 
      newWB.Close False 
     Next 
    End With 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
End Sub