none
Macro to split worksheet into multiple RRS feed

  • Question

  • Hi, I have a worksheet that I would like to split into 4 other worksheets. However, I need to keep the grouped rows together when transferring.  The way I would like for it to be split is by each 4th row.  I.e. row 2 and row 6 would be transferred to the same worksheet.  Keep in mind that the header would also need to be transferred to each of the new 4 worksheets.  Does anyone know how to create this type of macro?

    Help please!

    Thursday, November 2, 2017 6:08 PM

All replies

  • Excel 2010/2013/2016 Power Query (aka Get & Transform)
    Straight forward with a macro, but here is a later way with PQ.
    http://www.mediafire.com/file/ziawewcpczz3wpl/11_02_17.xlsx

    Thursday, November 2, 2017 7:20 PM
  • Hi Christine Surman,

    I would like to write VBA code (macro), but it's time-consuming task for me to input test data.

    Could you share your excel file via cloud storage such as OneDrive, Dropbox, etc?
    (Remember to edit/modify your personal/important data before sharing.)

    Regards,

    Ashidacchi

    Thursday, November 2, 2017 11:10 PM
  • Hi Christine Surman,

    You could try to test and adjust below code for your need.

    Sub SplitSheet()
        Dim SourceSheet As Worksheet
        Dim TargetSheet1 As Worksheet
        Dim TargetSheet2 As Worksheet
        Dim TargetSheet3 As Worksheet
        Dim TargetSheet4 As Worksheet
        Set SourceSheet = Sheets("SourceSheet")
        Set TargetSheet1 = Sheets("Sheet1")
        Set TargetSheet2 = Sheets("Sheet2")
        Set TargetSheet3 = Sheets("Sheet3")
        Set TargetSheet4 = Sheets("Sheet4")
        'Copy the header
        TargetSheet1.Rows(1) = SourceSheet.Rows(1).Value
        TargetSheet2.Rows(1) = SourceSheet.Rows(1).Value
        TargetSheet3.Rows(1) = SourceSheet.Rows(1).Value
        TargetSheet4.Rows(1) = SourceSheet.Rows(1).Value
        
        SourceSheetLastRow = SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row
        LoopCount = Int((SourceSheetLastRow - 2) / 4) + 1
        Dim SourceRange As Range
        Application.ScreenUpdating = False
        For i = 1 To LoopCount
        StartRow = (i - 1) * 4 + 2
        EndRow = i * 4 + 1
        Set SourceRange = SourceSheet.Range(SourceSheet.Rows(StartRow), SourceSheet.Rows(EndRow))
        SheetIndex = i Mod 4
        Select Case SheetIndex
        Case 1
             TargetSheet1.Range(TargetSheet1.Rows(i + 1), TargetSheet1.Rows(i + 4)) = SourceRange.Value
        Case 2
             TargetSheet2.Range(TargetSheet2.Rows(i), TargetSheet2.Rows(i + 3)) = SourceRange.Value
        Case 3
             TargetSheet3.Range(TargetSheet3.Rows(i - 1), TargetSheet3.Rows(i + 2)) = SourceRange.Value
        Case 0
             TargetSheet4.Range(TargetSheet4.Rows(i - 2), TargetSheet4.Rows(i + 1)) = SourceRange.Value
        End Select
        Next i
         Application.ScreenUpdating = True
    End Sub

    Here is the demonstration.

    Best Regards,

    Terry


    MSDN Community Support Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, November 3, 2017 2:30 AM
  • I think this will do what you want.

    Sub Copy_With_AutoFilter1()
    'Note: This macro use the function LastRow
        Dim My_Range As Range
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim FilterCriteria As String
        Dim CCount As Long
        Dim WSNew As Worksheet
        Dim sheetName As String
        Dim rng As Range
    
        'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
        'and the header of the first column, D is the last column in the filter range.
        'You can also add the sheet name to the code like this :
        'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
        'No need that the sheet is active then when you run the macro when you use this.
        Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
        My_Range.Parent.Select
    
        If ActiveWorkbook.ProtectStructure = True Or _
           My_Range.Parent.ProtectContents = True Then
            MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                   vbOKOnly, "Copy to new worksheet"
            Exit Sub
        End If
    
        'Change ScreenUpdating, Calculation, EnableEvents, ....
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        ActiveSheet.DisplayPageBreaks = False
    
        'Firstly, remove the AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        'Filter and set the filter field and the filter criteria :
        'This example filter on the first column in the range (change the field if needed)
        'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
        'Use "<>Netherlands" as criteria if you want the opposite
        My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"
    
        'If you want to filter on a cell value you can use this, use "<>" for the opposite
        'This example uses the activecell value
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value
    
        'This will use the cell value from A2 as criteria
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value
    
        ''If you want to filter on a Inputbox value use this
        'FilterCriteria = InputBox("What text do you want to filter on?", _
         '                              "Enter the filter item.")
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria
    
        'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
        CCount = 0
        On Error Resume Next
        CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
        On Error GoTo 0
        If CCount = 0 Then
            MsgBox "There are more than 8192 areas:" _
                 & vbNewLine & "It is not possible to copy the visible data." _
                 & vbNewLine & "Tip: Sort your data before you use this macro.", _
                   vbOKOnly, "Copy to worksheet"
        Else
            'Add a new Worksheet
            Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))
    
            'Ask for the Worksheet name
            sheetName = InputBox("What is the name of the new worksheet?", _
                                 "Name the New Sheet")
    
            On Error Resume Next
            WSNew.Name = sheetName
            If Err.Number > 0 Then
                MsgBox "Change the name of sheet : " & WSNew.Name & _
                     " manually after the macro is ready. The sheet name" & _
                     " you fill in already exists or you use characters" & _
                     " that are not allowed in a sheet name."
                Err.Clear
            End If
            On Error GoTo 0
    
            'Copy/paste the visible data to the new worksheet
            My_Range.Parent.AutoFilter.Range.Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                ' Remove this line if you use Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
    
            ' If you want to delete the rows that you copy, also use this
            ' With My_Range.Parent.AutoFilter.Range
            '     On Error Resume Next
            '     Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
            '               .SpecialCells(xlCellTypeVisible)
            '     On Error GoTo 0
            '     If Not rng Is Nothing Then rng.EntireRow.Delete
            ' End With
    
        End If
    
        'Close AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        'Restore ScreenUpdating, Calculation, EnableEvents, ....
        My_Range.Parent.Select
        ActiveWindow.View = ViewMode
        If Not WSNew Is Nothing Then WSNew.Select
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With
    
    End Sub
    
    
    Function LastRow(sh As Worksheet)
        On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", _
                                After:=sh.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlValues, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        On Error GoTo 0
    End Function


    Post back if you have additional questions.

    https://www.rondebruin.nl/win/s3/win006_1.htm


    MY BOOK


    • Edited by ryguy72 Saturday, November 4, 2017 5:16 AM
    • Proposed as answer by Terry Xu - MSFT Monday, November 6, 2017 1:03 AM
    Saturday, November 4, 2017 5:15 AM