VBA: Split data into multiple worksheets based on column

waxsublime

New Member
Joined
Jul 13, 2013
Messages
17
I'm trying to get this code I found (from How to split data into multiple worksheets based on column in Excel?) to work, but it's giving me an error.

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

Any ideas on how to fix this?

Thanks!
 
Last edited:
Like I said, you need to declare i as Long, not Integer. …

Especially as i is the “Bound Variable” and all other Loop Variables will be forced ( “coerced”?) in the loop workings to be of its Type regardless of how they may be dimensioned and used elsewhere in the code ;)………..






……
.. joeyc123,
The code looks a bit similar to ones I have done in threads.. If you are still having problems, maybe you can post some sample table showing the sort of data you have and importantly wot results you expect to get based on that data…

… If you are not sure how to do that some notes on ways to do it:-

. 1 If you can, try uploading this, https://onedrive.live.com/?cid=8cffd...CE27E813%21189 instructions here MrExcel HTML Maker . This free Excel add-In is good for screen shots here of spreadsheets. Then everyone can quickly see what is going on and follow the Thread easily.
Or
. 2 Up left in the Thread editor is a table icon. Click that, create an appropriately sized table and fill it in. (To get this icon up in the Reply window you may need to click on the “Go Advanced” Button next to the Reply Button)
Or
. 3 Supply us with example Excel files (Can of course be shortened, or made - up data in case any info is sensitive)
. For example send over this free thing: Box Net,
Remember to select Share after uploading and give us the link they provide.
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Especially as i is the “Bound Variable” and all other Loop Variables will be forced ( “coerced”?) in the loop workings to be of its Type regardless of how they may be dimensioned and used elsewhere in the code ;)………..

Hi DocAElstein,

This is the sample data i am working on. Basically i want Column C (called, "Record") as the reference so each unique record will be on separate sheet where the name of the sheet tab follows the Record name.

DateCurrencyRecordMid%Change
08/01/2014 7:31:18CHFCHF_2Y_3Y4.256.25%
08/01/2014 13:33:22CHFCHF_2Y_3Y4-5.88%
08/01/2014 13:48:48CHFCHF_2Y_5Y4.256.25%
08/01/2014 15:55:48CHFCHF_2Y_5Y4-5.88%
08/04/2014 7:30:01CHFCHF_2Y_3Y40.00%
08/04/2014 8:18:15CHFCHF_2Y_3Y3.75-6.25%
08/04/2014 8:19:24CHFCHF_2Y_3Y46.67%
08/04/2014 8:25:45CHFCHF_2Y_3Y40.00%
08/04/2014 8:40:37CHFCHF_2Y_3Y3.75-6.25%

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
.......
.....

This is the sample data i am working on. Basically i want Column C (called, "Record") as the reference so each unique record will be on separate sheet where the name of the sheet tab follows the Record name.....
. ..........
.....................


. OK.
. That looks simple enough even for me. I expect your problems are more subtle coming from your actual data as the sample data is very simple and small. But anyways…..
…. If I assume your initial file looks like this with just one sheet in it (or only one with all data in it)…



Book1
ABCDEF
1DateCurrencyRecordMid%Change
208.01.2014 07:31CHFCHF_2Y_3Y4.256.25%
308.01.2014 13:33CHFCHF_2Y_3Y4-5.88%
408.01.2014 13:48CHFCHF_2Y_5Y4.256.25%
508.01.2014 15:55CHFCHF_2Y_5Y4-5.88%
608.04.2014 07:30CHFCHF_2Y_3Y40.00%
708.04.2014 08:18CHFCHF_2Y_3Y3.75-6.25%
808.04.2014 08:19CHFCHF_2Y_3Y46.67%
908.04.2014 08:25CHFCHF_2Y_3Y40.00%
1008.04.2014 08:40CHFCHF_2Y_3Y3.75-6.25%
11
FullDataSheet


. If you then apply the code I give at the end of this post then you get 2 additional sheets added which look like these


Book1
ABCDEF
1DateCurrencyRecordMid%Change
208.01.2014 13:48CHFCHF_2Y_5Y4.256.25%
308.01.2014 15:55CHFCHF_2Y_5Y4-5.88%
4
CHF_2Y_5Y



Book1
ABCDEF
1DateCurrencyRecordMid%Change
208.01.2014 07:31CHFCHF_2Y_3Y4.256.25%
308.01.2014 13:33CHFCHF_2Y_3Y4-5.88%
408.04.2014 07:30CHFCHF_2Y_3Y40.00%
508.04.2014 08:18CHFCHF_2Y_3Y3.75-6.25%
608.04.2014 08:19CHFCHF_2Y_3Y46.67%
708.04.2014 08:25CHFCHF_2Y_3Y40.00%
808.04.2014 08:40CHFCHF_2Y_3Y3.75-6.25%
9
CHF_2Y_3Y


. So the code is below. As I am learning I have a lot of explaining comments which look a bit confusing here. But if you copy the code in your Code window it is a bit more readable as my comments are on one line and so in the Code window (the Visual Basic Editor or development Window obtained by Alt F8) most comments “truncated off” on your screen to make it more readable!
. The code as written is designed to be used to update files. So every time you run it the record files are deleted first if they are already there.
. If you still have any problems then get back, and maybe send a file with more representative data in it and I can get the code working on that (assuming wot my code is doing is the sort of thing you want) and send the file back via the Thread with a link.
. I can send the working example file with a link If you want?

Alan

P.s. there are lots of threads doing this sort of thing but the title is not as good as this one so does not come up so good in a search. Here are a few
http://www.mrexcel.com/forum/excel-...lter-copy-paste-tabs-based-value-columna.html
http://www.mrexcel.com/forum/excel-...her-worksheet-if-column-=-specific-value.html
http://www.mrexcel.com/forum/excel-questions/799667-copying-row-based-coloumn-contents-2.html

The last one is where I “stole” the important bits for this code. So credit goes to Alan_P really for the code.

Here it is:

Code:
[color=darkblue]Option[/color] [color=darkblue]Explicit[/color] [color=green]'Not necerssary but good practice to keep computer memery usage to minimum (and helps show up errors)[/color]
[color=darkblue]Sub[/color] joeyc123AdvFiltZuNeuTab****()
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off.[/color]
[color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] TheEnd [color=green]'If anything goes wrong go to the End instead of crashing.[/color]
 
[color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet [color=green]'ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=green]'Start Bit to  Delete Sheets / Tabs------------[/color]
Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] ActiveWorkbook.Worksheets
    [color=darkblue]If[/color] ws.Name <> "FullDataSheet" [color=darkblue]Then[/color]
    ws.Delete
    [color=darkblue]Else[/color] [color=green]'Presumably then the worksheet name is FullDataSheet so[/color]
    [color=green]' do nothing (Don't delete it!)[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
[color=darkblue]Next[/color]
Application.DisplayAlerts = [color=darkblue]True[/color] [color=green]'Turn it back on[/color]
[color=green]'End Bit to delete new Sheets / Tabs------------[/color]
 
[color=green]'Add new Worksheets---[/color]
[color=darkblue]Dim[/color] Record [color=darkblue]As[/color] [color=darkblue]String[/color] [color=green]'Record name, not kept constant, used / updated in looping[/color]
[color=darkblue]Dim[/color] LastRecordRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Assume initially you have no more than 255 Records. Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
[color=darkblue]Let[/color] Worksheets.Add(After:=Worksheets(1)).Name = "Unique1" [color=green]'Add a Worksheet after the first, named Unique1 for now[/color]
[color=darkblue]Let[/color] LastRecordRow = Sheets("FullDataSheet").Range("C" & Rows.Count).End(xlUp).Row
Sheets("FullDataSheet").Range("C1:C" & LastRecordRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=[color=darkblue]True[/color] [color=green]'Copies entire L Column to first column in sheet2 (Tempory made "Unique1" sheet), The important bit is Unique:=True - that only copies unique bits[/color]
[color=green]'---------------------[/color]
 
[color=darkblue]Dim[/color] LastUnqRow [color=darkblue]As[/color] [color=darkblue]Long[/color], UqeRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Rows in Tempory Unique sheet. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
[color=darkblue]Let[/color] LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Unique Row for use in next loop. method: You starta at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers)[/color]
  [color=darkblue]For[/color] UqeRow = 2 [color=darkblue]To[/color] LastUnqRow [color=darkblue]Step[/color] 1 [color=green]'[/color]
    'Make new sheet------------
    [color=darkblue]If[/color] Sheets("Unique1").Cells(UqeRow, 1).Text <> "" [color=darkblue]Then[/color] [color=green]'Assuming a Record is there[/color]
    [color=darkblue]Let[/color] Record = Sheets("Unique1").Cells(UqeRow, 1).Text [color=green]'Put name in Record variable[/color]
    [color=darkblue]Let[/color] Worksheets.Add(After:=Worksheets(1)).Name = Record [color=green]'Add new worksheet with Record name[/color]
   
   
      [color=darkblue]With[/color] Sheets("FullDataSheet") [color=green]'Copying data to new sheet----[/color]
        .UsedRange.AutoFilter Field:=3, Criteria1:=Record [color=green]'Filter out everything except with that with the appropriate Record (makes visible based on the criteria only the stuff you want??)....[/color]
        .UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Record).Range("A1") [color=green]', then combine it with SpecialCells to just copy that wot you see, (and then send it to the relavent new sheet , name n).. ( Idid notice that it works the same without the .SpecialCells(xlCellTypeVisible) bit, - but that mayjust be Excel “guessing wot you want” as it does, that is to say it copies by default wot is visible?- not too sure on that one yet.)[/color]
      [color=darkblue]End[/color] [color=darkblue]With[/color] [color=green]'-------------------------------------------------[/color]
   
      [color=darkblue]With[/color] Sheets(Record).UsedRange [color=green]'Bit of simple Format Tidying up[/color]
        .WrapText = [color=darkblue]False[/color]
        .Columns.AutoFit
      [color=darkblue]End[/color] [color=darkblue]With[/color]
    [color=darkblue]Else[/color]
    [color=green]'Do nothing if no Record given[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=green]'-----------------------------[/color]
  [color=darkblue]Next[/color] UqeRow [color=green]'Go back and make another ner sheet[/color]
 
Sheets("FullDataSheet").AutoFilterMode = [color=darkblue]False[/color]
 
Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevent being asked if you really want to delete Temporary Unique sheet[/color]
Sheets("Unique1").Delete [color=green]' delete the filtered Record name sheet as you do not need it any more[/color]
Application.DisplayAlerts = [color=darkblue]True[/color]
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Turn screen "back on" or screen is "dead"[/color]
[color=darkblue]Exit[/color] [color=darkblue]Sub[/color] [color=green]'We stop code here assuming it worked (or at least did not crash!)[/color]
TheEnd:
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Important to do this here so if anything goes wron then the screen updating is turned back on, ohterwisee the screen is dead[/color]
MsgBox (Err.Description) [color=green]'Print out error message in Message Box[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'joeyc123AdvFiltZuNeuTab****()[/color]
 
Upvote 0
Hi Doc,

The end result you showed is exactly what i am aiming for. Just remember that i am always want to filter values based on the column Record and my data may range up to 350,000 rows. I copied the code but it is not doing it. I have this below highlighted in red and the macro is not being saved.

Option Explicit 'Not necerssary but good practice to keep computer memery usage to minimum (and helps show up errors)
Sub joeyc123AdvFiltZuNeuTab****()
Application.ScreenUpdating = False 'Not necerssary but speeds things up a bit, by turning screen updating off.
On Error GoTo TheEnd 'If anything goes wrong go to the End instead of crashing.
 
Last edited by a moderator:
Upvote 0
Hi Doc,

The end result you showed is exactly what i am aiming for. Just remember that i am always want to filter values based on the column Record and my data may range up to 350,000 rows. I copied the code but it is not doing it. I have this below highlighted in red and the macro is not being saved.
........
Sub joeyc123AdvFiltZuNeuTab****()..........


. Hi
. Simply delete those **** - I Put in a naughty word S__t and the MrExcel editor censored it!, and changed it to **** which VBA code does not like!!!
Alan
 
Upvote 0
……….Finally, now it worked.. Perfectly! Thanks so much
clip_image001.gif

. You’re Welcome
. Glad it worked for You (And somewot surprised with column data ranges up to 350,000 rows! – I have problems with my codes bombing out at around 3000 sometimes!)
. Many thanks for the feedback
Alan
 
Upvote 0
. You’re Welcome
. Glad it worked for You (And somewot surprised with column data ranges up to 350,000 rows! – I have problems with my codes bombing out at around 3000 sometimes!)
. Many thanks for the feedback
Alan


Hi Doc,

I came across another problem this time i am creating a Leave Tracker for my Team. The code below allows everyone to update the excel sheet and sends an email to our team email automatically in outlook however i want the code to also say in the email (MAYBE MSG BODY) which cell was updated and what's the content of that cell e.g. "Joey VL" for joey Vacation Leave or Joey SL for sick leave so everyone in the team know who is on leave on that particular day. Can you help me with this please?
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
 
Dim answer As String
 
answer = MsgBox("Do you want to send an update to the team?", vbYesNo, "Save the file")
 
If answer = vbNo Then Cancel = True
If answer = vbYes Then
'open outlook type stuff
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set newmsg = OutlookApp.CreateItem(olMailItem)
'add recipients
'newmsg.Recipients.Add ("ETI TEAM")
newmsg.Recipients.Add ("eti.team@eti.com")
'add subject
newmsg.Subject = "2015 Leave Tracker"
'add body
newmsg.Body = "Leave tracker was updated"
newmsg.Display 'display
newmsg.Send 'send message
'give conformation of sent message
MsgBox "Email will be sent to Markets ETI Team", "Email Sent"
 
 
 
End If
 
 
'save the document
'Me.Worksheets.Save
 
End Sub
 
Last edited by a moderator:
Upvote 0
Hi Doc,

I came across another problem this time i am creating a Leave Tracker for my Team. The code below allows everyone to update the excel sheet and sends an email to our team email automatically in outlook however i want the code to also say in the email (MAYBE MSG BODY) which cell was updated and what's the content of that cell e.g. "Joey VL" for joey Vacation Leave or Joey SL for sick leave so everyone in the team know who is on leave on that particular day. Can you help me with this please?
........

. Sorry joeyc. I took a good look, but this one is way above me. I am just now learning Excel VBA and I have no experience with Email or Outlook.

. Maybe someone else can help?

. Actually joeyc as it is a comletely new Problem it might be best to start a new Thrread.

Good Luck

Alan
 
Upvote 0
Thanks mirabeau. That macro is a LOT faster. But it's giving me an error on the name for the sheet:

Runtime 1004:
Name can't exceed 31 char
name cannot contain characters: : /\?*
You did not leave the name blank

The other macro didn't give the error, but I also haven't checked to see if it did everything correctly. Anyway, thanks again!


These VBA codes seem just what I need but the name of the data I want to split contains "/". My question is, therefore, is it possible to split data with "/" in the name? or would I need to rename the cells first. If so could someone help me with what the code would be and where it would appear within the code used to split the data into multiple worksheets.

I am new to VBA and am still trying to understand it, so any help would be appreciated.
 
Upvote 0

Forum statistics

Threads
1,213,565
Messages
6,114,337
Members
448,568
Latest member
Honeymonster123

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