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

B

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

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
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
mumps said:
Do you want a separate sheet for each SUPPLIER OR MFGR ?
Click to expand...
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
Fuji said:
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
Click to expand...
this is perfect! thank you!!
 
Upvote 0
Fuji said:
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
Click to expand...
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
You must log in or register to reply here.

Similar threads

C
  • Locked
  • Question Question
How do I Split a column into new workbooks that get saved and named?
Replies
1
Views
478
Fluff
Fluff
C
  • Question Question
VBA Code to Split a column into new workbooks
Replies
3
Views
1K
mohadin
M
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
374
Minh Tuan VN
M
D
  • Question Question
Print Multiple invoices in one PDF File
Replies
1
Views
358
John_w
J
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
133
vanessavalentino83
V

Forum statistics

Threads
1,224,885
Messages
6,181,582
Members
453,055
Latest member
cope7895

Share this page

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