Split Spreadsheet into Multiple Sheets

dlo1503

New Member
Joined
Feb 24, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
Hi

I am writing a code to split a spreadsheet into multiple sheets. I need help with the following issues

1. The headers for the table appear in Row 8 however there is other data from A1:J7 that I would like to appear above as well in the split sheets. At the minute only the table headers A8:J8 appear. The values in cells A1:J7 can be copied and pasted to each sheet.

2. In Cell C4 there is a numerical value. For each sheet that it splits "DAILY PARTS" into I would like this value to increase by 1 for each of them. E.g. if the original C4 says 300 for the first new sheet it reads 301, for sheet 2 it reads 302 etc. After creating the sheets I would like the original to change to whatever the last newly created sheet read. E.g. if there were 4 new cells they would read 301, 302, 303, 304. The original would then change to 304.

3. I would like the new sheets to be renamed as the new value in C4, a space and then the value they are being filtered by

4. Last problem, when I run the current code it creates a sheet first of the headers in Cells A8:J8 with the sheet name of cell J8. Can't work out why that's happening.

Thanks
Daniel

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="10", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.count, vcol).End(xlUp).Row
title = "A8"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
 
Last edited:

Some videos you may like

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,618
Office Version
  1. 2007
Platform
  1. Windows
Try this:

VBA Code:
Sub parse_data()
  Dim sh1 As Worksheet, rg1 As Range, rg2 As Range
  Dim vcol As Variant, ky As Variant, i As Long
  Dim dic As Object, sName As String
  
  Application.ScreenUpdating = False
  vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="10", Type:=1)
  If vcol = "" Or vcol = False Then Exit Sub
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = ActiveSheet
  Set rg1 = sh1.Range("A8")
  Set rg2 = sh1.Range("C4")
  
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  For i = rg1.Row + 1 To sh1.Cells(Rows.Count, vcol).End(3).Row
    dic(sh1.Cells(i, vcol).Value) = Empty
  Next
  
  For Each ky In dic.keys
    sh1.Range(rg1, sh1.Cells(Rows.Count, vcol).End(3)).AutoFilter vcol, ky
    rg2.Value = rg2.Value + 1
    sName = rg2.Value & " " & ky
    If Not Evaluate("=ISREF('" & sName & "'!A1)") Then
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = sName
    Else
      Sheets(sName).Move After:=Worksheets(Worksheets.Count)
    End If
    sh1.Range("A1", sh1.Range("A" & Rows.Count).End(3)).EntireRow.Copy Sheets(sName).Range("A1")
  Next
  
  sh1.Activate
  sh1.AutoFilterMode = False
  Application.ScreenUpdating = True
End Sub
 

dlo1503

New Member
Joined
Feb 24, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
Thank you for your reply DanteAmor, I am getting a 1004 Error on line

sh1.Range(rg1, sh1.Cells(Rows.Count, vcol).End(3)).AutoFilter vcol, ky

AutoFilter method of Range class failed

Any ideas?
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,618
Office Version
  1. 2007
Platform
  1. Windows
You can put a sample of your data, use the XL2BB tool
 

Watch MrExcel Video

Forum statistics

Threads
1,127,348
Messages
5,624,145
Members
416,014
Latest member
MickP69

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
Top