Einen angegebenen Bereich von Arbeitsblättern in eine neue Arbeitsmappe unter einem neuen Namen aufteilen

Question

Ich habe versucht, eine Arbeitsmappe in separate Arbeitsmappen aufzuspalten, basierend auf identifizierten Arbeitsblättern in der Arbeitsmappe. Beispiel: Angenommen, ich hatte ein Arbeitsblatt für jeden Buchstaben im Alphabet.

Ich möchte aufzuspalten einer Tabelle A bis C in eine neue Arbeitsmappe mit dem Namen „A bis C.“

D bis I in eine neue Arbeitsmappe mit dem Namen „D bis I“ gehen

etc ...

würde meine Idee zuerst sein, ein Arbeitsblatt einfügen, die das neue Arbeitsmappe wird es, und die Spalten B bis so viele Spalten in Spalte A Namen, da es werden die Namen der Arbeitsblätter sein kopiert in die neue Arbeitsmappe.

Hat jemand eine Idee, wie ein Makro für diese zu machen? Ich habe es selbst versucht, war aber erfolglos.

Vielen Dank!

Ich fand dieses Makro da draußen. Glaubt jemand, dass es geändert werden kann, um zu arbeiten?

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

Der folgende Code vorausgesetzt, dass Sie Ihre Steuer Blatt haben (so genannte „Split-Parameter“) in der Arbeitsmappe, die das Makro enthält, und es wird mit den gewünschten Dateinamen in Spalte A aufgeführten und die Blätter, die Sie in diese Datei kopieren möchten (aus dem ActiveWorkbook, das möglicherweise das Makro enthält), das in den Spalten B, C usw. aufgeführt ist. Zeile 1 wird als Überschrift betrachtet und daher ignoriert .

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