Splitting up an excel file to multiple tabs by "visible" rows.

BasicUserWithExp

New Member
Joined
Feb 15, 2018
Messages
17
I found a post: "Splitting up an excel file by rows." it works well for what i need, but I want it to split the rows on an already filtered sheet.

I have a master list of parts. the list contains a column for qty, I filter it to show only parts with quantity greater than zero. That list then needs to only show a max of 60 items per sheet.
here is the code:

VBA Code:
Sub CopyTable()
 
    'Set dimensions
    Dim Table As Range, TableArray(), _
        CutValue As Integer, Cntr As Integer, _
        TempArray(), Width As Integer, _
        x As Integer, y As Integer, _
        Height As Long, Rep As Integer, _
        LoopReps As Long
 
    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=900)
    Width = Table.Columns.Count
    Height = Table.Rows.Count
 
    'Write to array
    TableArray = Table
    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CutValue
 
    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CutValue < CutValue Then _
            LoopReps = Height - Cntr * CutValue
 
        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CutValue, x)
            Next y
        Next x
 
        Worksheets.Add
        Range("A1").Resize(LoopReps, Width) = TempArray
    Next Cntr
End Sub
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
Do you want a separate sheet for each SUPPLIER OR MFGR ?
 
Upvote 0
Do you want a separate sheet for each SUPPLIER OR MFGR ?
no, i have to add the lists to a blueprint. i want to only show the parts that are present, and only 60 rows need to be shown.
Screenshot 2024-11-08 205948.png
 
Upvote 0
Try:
VBA Code:
Sub SplitData()
    Application.ScreenUpdating = False
    Dim x As Long, i As Long, srcRng As Range, rng As Range, copyRng As Range, cnt As Long, srcWS As Worksheet, y As Long: y = 1
    Set srcWS = Sheets("MASTER LIST")
    With srcWS
        .ListObjects("Table9").Range.AutoFilter Field:=3, Criteria1:=">0"
        Set srcRng = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        For Each rng In srcRng
            cnt = cnt + 1
        Next rng
        For x = 1 To cnt Step 60
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "List " & y
            For Each rng In srcRng
                i = i + 1
                If i <= 60 Then
                    If copyRng Is Nothing Then Set copyRng = srcWS.Range("A" & rng.Row) Else Set copyRng = Union(copyRng, srcWS.Range("A" & rng.Row))
                End If
            Next rng
            With copyRng
                .EntireRow.Copy Sheets("List " & y).Range("A1")
                .EntireRow.Hidden = True
            End With
            Set copyRng = Nothing
            Columns.AutoFit
            On Error Resume Next
            Set srcRng = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            i = 0
            y = y + 1
        Next x
    End With
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I forgot to mention that the macro does the filtering for you based on Qty>0.
 
Upvote 0
Filter the data as you wish before you run the code.
If not filtered, it just separates the rows.
Code:
Sub test()
    Dim a, e, s, x, y, z, cols, n&, i&, temp, wsName$, ws As Worksheet
    Const myStep& = 60
    With Sheets("master list").ListObjects(1)
        cols = Evaluate("column(" & Columns(1).Resize(, .ListColumns.Count).Address & ")")
        s = Replace(.Range(1).Address(0, 0), .Range(1).Row, "")
        x = Split(Replace(.Range.Columns(1).SpecialCells(12).Address(0, 0), s, ""), ",")
        ReDim a(1 To .ListRows.Count + 1)
        For Each e In x
            If e Like "*#:#*" Then
                For i = Split(e, ":")(0) To Split(e, ":")(1)
                    n = n + 1: a(n) = i - .Range.Row + 1
                Next
            Else
                n = n + 1: a(n) = e - .Range.Row + 1
            End If
        Next
        ReDim Preserve a(1 To n)
        For i = 2 To UBound(a) Step myStep
            If UBound(a) >= i + myStep Then
                wsName = "From " & i - 1 & " To " & i - 2 + myStep
                Set ws = CreateWS(wsName)
                If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
                z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & myStep + i - 1 & "))"), ","), ","))
                temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
                GetData ws, temp
            Else
                Exit For
            End If
        Next
        If UBound(a) > i - 1 Then
            wsName = "From " & i - 1 & " to Last"
            Set ws = CreateWS(wsName)
            z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & UBound(a) & "))"), ","), ","))
            temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
            GetData ws, temp
        End If
    End With
End Sub

Function CreateWS(wsName$) As Worksheet
    If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
    Set CreateWS = Sheets(wsName)
    CreateWS.[a1].CurrentRegion.ClearContents
End Function

Sub GetData(ws As Worksheet, temp)
    With ws.[a1].Resize(UBound(temp, 1), UBound(temp, 2))
        .Value = temp
        .Columns.AutoFit
    End With
End Sub
 
Upvote 0
Solution
Filter the data as you wish before you run the code.
If not filtered, it just separates the rows.
Code:
Sub test()
    Dim a, e, s, x, y, z, cols, n&, i&, temp, wsName$, ws As Worksheet
    Const myStep& = 60
    With Sheets("master list").ListObjects(1)
        cols = Evaluate("column(" & Columns(1).Resize(, .ListColumns.Count).Address & ")")
        s = Replace(.Range(1).Address(0, 0), .Range(1).Row, "")
        x = Split(Replace(.Range.Columns(1).SpecialCells(12).Address(0, 0), s, ""), ",")
        ReDim a(1 To .ListRows.Count + 1)
        For Each e In x
            If e Like "*#:#*" Then
                For i = Split(e, ":")(0) To Split(e, ":")(1)
                    n = n + 1: a(n) = i - .Range.Row + 1
                Next
            Else
                n = n + 1: a(n) = e - .Range.Row + 1
            End If
        Next
        ReDim Preserve a(1 To n)
        For i = 2 To UBound(a) Step myStep
            If UBound(a) >= i + myStep Then
                wsName = "From " & i - 1 & " To " & i - 2 + myStep
                Set ws = CreateWS(wsName)
                If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
                z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & myStep + i - 1 & "))"), ","), ","))
                temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
                GetData ws, temp
            Else
                Exit For
            End If
        Next
        If UBound(a) > i - 1 Then
            wsName = "From " & i - 1 & " to Last"
            Set ws = CreateWS(wsName)
            z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & UBound(a) & "))"), ","), ","))
            temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
            GetData ws, temp
        End If
    End With
End Sub

Function CreateWS(wsName$) As Worksheet
    If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
    Set CreateWS = Sheets(wsName)
    CreateWS.[a1].CurrentRegion.ClearContents
End Function

Sub GetData(ws As Worksheet, temp)
    With ws.[a1].Resize(UBound(temp, 1), UBound(temp, 2))
        .Value = temp
        .Columns.AutoFit
    End With
End Sub
this is perfect! thank you!!
 
Upvote 0
Filter the data as you wish before you run the code.
If not filtered, it just separates the rows.
Code:
Sub test()
    Dim a, e, s, x, y, z, cols, n&, i&, temp, wsName$, ws As Worksheet
    Const myStep& = 60
    With Sheets("master list").ListObjects(1)
        cols = Evaluate("column(" & Columns(1).Resize(, .ListColumns.Count).Address & ")")
        s = Replace(.Range(1).Address(0, 0), .Range(1).Row, "")
        x = Split(Replace(.Range.Columns(1).SpecialCells(12).Address(0, 0), s, ""), ",")
        ReDim a(1 To .ListRows.Count + 1)
        For Each e In x
            If e Like "*#:#*" Then
                For i = Split(e, ":")(0) To Split(e, ":")(1)
                    n = n + 1: a(n) = i - .Range.Row + 1
                Next
            Else
                n = n + 1: a(n) = e - .Range.Row + 1
            End If
        Next
        ReDim Preserve a(1 To n)
        For i = 2 To UBound(a) Step myStep
            If UBound(a) >= i + myStep Then
                wsName = "From " & i - 1 & " To " & i - 2 + myStep
                Set ws = CreateWS(wsName)
                If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
                z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & myStep + i - 1 & "))"), ","), ","))
                temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
                GetData ws, temp
            Else
                Exit For
            End If
        Next
        If UBound(a) > i - 1 Then
            wsName = "From " & i - 1 & " to Last"
            Set ws = CreateWS(wsName)
            z = Application.Index(a, Split("1," & Join(Evaluate("transpose(row(" & i & ":" & UBound(a) & "))"), ","), ","))
            temp = Application.Index(.Range.Value, Application.Transpose(z), cols)
            GetData ws, temp
        End If
    End With
End Sub

Function CreateWS(wsName$) As Worksheet
    If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
    Set CreateWS = Sheets(wsName)
    CreateWS.[a1].CurrentRegion.ClearContents
End Function

Sub GetData(ws As Worksheet, temp)
    With ws.[a1].Resize(UBound(temp, 1), UBound(temp, 2))
        .Value = temp
        .Columns.AutoFit
    End With
End Sub
I just found out, i may not be able to use Macros in my spreadsheets, is it possible to do this without VBA?
 
Upvote 0

Forum statistics

Threads
1,223,934
Messages
6,175,487
Members
452,647
Latest member
MatthewBiersay

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top