CODEWITHSUNDEEP
vbaexcel
Elliot Vazquez
Elliot Vazquez

Reputation: 9

Breaking down a spreadsheet into multiple sheets by column

I am currently trying to figure out a way to breakdown a 10000 item sheet by column. I am using the code in the below link.

https://www.extendoffice.com/documents/excel/1174-excel-split-data-into-multiple-worksheets-based-on-column.html

However, I am having trouble getting it to work. I do not know how to code, but I do know how to follow directions. This is my code, after edits

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
vcol = 15
Set ws = Sheets("Sheet1") 
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "01:Z1"
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(xlCellType Constants))
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")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

According to the site, I should be dividing my spread sheet up by the different names in my O column (ie, department1, department 2, etc). However, Im getting back error 1004. I think this maybe to the vcol value (I put 15 because O is the 15th letter in the alphabet). Could anyone here help me out? Thanks in advance.

Upvotes: 0

Views: 275

Answers (1)

gtwebb
gtwebb

Reputation: 3011

The code appears to work fine for me, I'll give you some steps to check what its doing.

You can go to a line press f9 and it will create a break point where the code will stop and you can see whats going on.

This part should create a list in the last column of the sheet (column XFD probably) with all the unique values from your selected column and then save it in an array. Make a break on the last line and make sure you have that list. 

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))

This applies a filter to your data so it can copy just the filtered data (you don't have a blank second row do you.

ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

This creates a new sheet and copies the data over

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")

The only reason I can think that all the data would be copied is if its not filtering properly. So try manually adding a filter and see what it does.

Upvotes: 1

Related Questions