VBA: Split data into multiple worksheets based on column

[waxsublime]

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.

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!

 

[DocAElstein]

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.

Hi.
You will likely not get any reply from Mirabeau because he appears to be banned from us?. I did some of the last codes here. I am not too clued up on the earlier ones from Mirabeau. It is difficult to see exactly where your problem lies. I think anyone else trying to help will also need more info.
. Take a look at wot I said to joeyc123 in Post #21 above.
. If you get some more info across along those lines and no one else picks up the Thread then I will have a look later.
Alan

 

[karan1916]

Hello, I am just reviving this old thread regarding Splitting data into multiple sheets. I got the below code from this forum, it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. I would appreciate any help in this. Sub Staffing_Budget_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 = 1 'set column number
Set ws = Sheets("FTE Summary") 'set sheet name
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:I1" ' set title row
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

 

[DocAElstein]

Hello, I am just reviving this old thread regarding Splitting data into multiple sheets. I got the below code from this forum, it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. I would appreciate any help in this. ...........

Hi,
. I was in this Thread a bit. But do not recognize that particular code. So It is a bit difficult for me to see clearly the problem. If you can help give me some more insight then I will see if I can help you.
. For example if you could drop off a working file with the macro in you are using ( for example over this free thing:
Box Net,
) then I can get a clearer picture of wot is going on. Try to include good representative data and if possible provide in another file or sheet / sheets some hand written by you results as you want the results to look like based on that example data. (Obviously if your data is sensitive them change it or make it up – important is just that it has a good spread of data type to represent typical situations. That way the code can be fully tested).

Alan

 

[karan1916]

Hi,
. I was in this Thread a bit. But do not recognize that particular code. So It is a bit difficult for me to see clearly the problem. If you can help give me some more insight then I will see if I can help you.
. For example if you could drop off a working file with the macro in you are using ( for example over this free thing:
Box Net,
) then I can get a clearer picture of wot is going on. Try to include good representative data and if possible provide in another file or sheet / sheets some hand written by you results as you want the results to look like based on that example data. (Obviously if your data is sensitive them change it or make it up – important is just that it has a good spread of data type to represent typical situations. That way the code can be fully tested).

Alan

Dear Alan, Thanks a lot for getting back to me. Here is the link to the file https://app.box.com/s/1fda9djd3fhpzr90b8xm . This contains actual representation of the data. The code that I used above, I had copied it from this website. It does copy paste special when it copies it into a different sheet. My original request was that when it saves the data in the new worksheet, it should retain the formula. I have now a further request. Instead of saving them to the same workbook by adding new tabs, I would need the data to be copied in a new excel workbook. The new workbook can have the same name based on the unique value. if there are 50 unique values then I should have 50 workbooks in the folder. I tried looking for this everywhere but I couldn't find this solution. I am hoping you can help. Thanks. Karan

 

[DocAElstein]

. Hi karan,
. On the face of it it looks easy. I probably just need to modify codes I have already done for people…But so I can try to get it right first time: Please appreciate You probably know this project inside and out. I see it for the first time so, You need to spell it out a bit more clearly exactly wot Yous want
.
. So a few questions.

……. I got the code from this forum, it does exactly everything I need it to do except ……
…. The code that I used ……….I had copied it from this website. QUOTE]

. 1) Did you mean you tried the code and it did almost wot you wanted? If so then send me the .xlsm file or shortened version of, that you tried, as originally requested. If you did not try it, no problem – just tell me so I do not waste my time trying getting it to work with your data.
…………………………….

……. ……..it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. ……………………….

. 2) I see no formulas in the file you sent so I do not quite understand. The data needs to be representative which means if you have and want formulas to be copied then it should have some typical formulas in it.

…………………………………………

…….. I have now a further request. Instead of saving them to the same workbook by adding new tabs, I would need the data to be copied in a new excel workbook. The new workbook can have the same name based on the unique value. if there are 50 unique values then I should have 50 workbooks in the folder. ………

.3 ) whether the code makes a new sheet or new workbook is hardly any difference to the coding, so no problem at all there. Wot is a problem for me is it is still not obvious exactly how a new sheet or sheet in a new file should Look like. I guess your unique values are those in column D. But Please supply at least one sheet in the same or a new workbook showing exactly how your final data should look like based on your sample data.

.3b) Unique values usually implies (I think?) that you may have duplicates to be ignored. I do not see any, at least in D? Please clarify, and again if there may be duplicates then the sample data should have a few in.

. If you clear up those bits, resend a file, then I think it should be no problem.

Alan

 

[karan1916]

Hi Thanks for the quick response. here is the link to Xlsm file. https://app.box.com/s/jhrz9hexel1586iwqegc So I had tried the macro and it splits Sheet 1 into various tabs as required but there is a Sum formula in column E, F, G H in the rows where it says Total. I need to retain that formula. For some weird reason the formula remains in the first copied tab (see comments in the first copied tab) but doesn't have the formula in any subsequent tab. The macro looks at unique values in Column A and creates tab based on that, which is what I require, doesn't need to look at column D. I searched a bit more and have found the macro that splits these separate tabs into separate files. So the main thing is to tweak the existing macro to retain the formulas in the original data. thanks a lot for your help

 

[DocAElstein]

Hi Karan..
. I a bit with this one.
. I could not (and still don’t yet) understand why the formulas do not copy after the first sheet!?.
….. I tried to use the excuse that as it was not my code and badly commented I could not really see wot it was doing exactly..
. So I modified one of my codes to do the job…
. And guess wot.- It only copies the formulas to the first sheet !! ARGHHHHH!!!!!

. I expect there is either some sort of refreshing command to Advanced Filter Copy to be applied after the first time it is used or some extra argument, or a fundamental limit in the Advanced Filter Copy thing. But to date no amount of Googling has found it.

. Interesting problem so I will keep trying. (Or maybe an expert will enlighten us on this one sometime!!. The question has been asked in this and other forums.. but the ones I googled were not answered!!).

. In the meantime I did a Bodge for you in my code. I don’t like it but for now it may get you by before we sort it out properly. Basically it Re – Copies again using the standard Copy – Paste thing using the information to get the correct Range dimensions to Copy from the first attempt at copying with Advanced Filter (which again works except that after the first sheet no formulas are copied ) The Code / codes all seem to work on the data you gave. (For now writing to a new sheet.)

. I will post the code for now, along with the working File, and then take another look tomorrow. (Maybe I will Bodge the code you sent once I understand it better) Let me know how you get on, and also let me know if you try that Sheet to File Code You found. I would be interested to take a look at that.

Main code (with messy ‘comments mainly for my benefit):

[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] KaranAdvFiltBodgeCopy()
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 <> "Sheet1" [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 any Sheets / Tabs------------[/color]
 
[color=green]'Add new Worksheets---[/color]
    [color=green]'Make Tempory Sheet[/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]' Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
    [color=darkblue]Dim[/color] LastRecordColumn [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here[/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("Sheet1").Range("A" & Rows.Count).End(xlUp).Row [color=green]'Go to last row in  Column 1, come back up to last entry and get the row there..allows for differnt versions of Excel with different number of rows.[/color]
    Sheets("Sheet1").Range("A1:A" & LastRecordRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=[color=darkblue]True[/color] [color=green]'Copies entire A Column to first column in sheet2 (Tempory made "Unique1" sheet), The important bit is Unique:=True - that only copies unique Nuimbers[/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) Just a different method here for fun- finds last row in sheet rather than last entry in particular cell[/color]
 [color=green]'### get Row Indices for Stupid Bodge[/color]
  [color=darkblue]Dim[/color] BodgeStartRow [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] BodgeStartRow = 2
  [color=darkblue]Dim[/color] RangeBodgeRows [color=darkblue]As[/color] [color=darkblue]Long[/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("Sheet1") [color=green]'Copying data to new sheet----[/color]
        .UsedRange.AutoFilter Field:=1, 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=green]'### Copy Bodge[/color]
  Sheets("Sheet1").AutoFilterMode = [color=darkblue]False[/color]
  [color=darkblue]Let[/color] LastRecordColumn = Sheets(Record).Cells(2, Columns.Count).End(xlToLeft).Column [color=green]'Start in first Column second row, go to the last column in that row, come back to last entry and get the column number of it. Allows for differet Column numbers but for karan Column I would 'ave done!![/color]
  [color=darkblue]Let[/color] RangeBodgeRows = Sheets(Record).Range("A" & Rows.Count).End(xlUp).Row [color=green]'Needed range row length (+1) for copy bodge[/color]
    [color=green]'Re - Copy as Bodge to get Formulas[/color]
    Sheets("Sheet1").Range(Sheets("Sheet1").Cells(BodgeStartRow, 1), Sheets("Sheet1").Cells(BodgeStartRow + RangeBodgeRows - 2, LastRecordColumn)).Copy
    Sheets(Record).Range("a2").Select
    ActiveSheet.Paste
 
  [color=darkblue]Let[/color] BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
  [color=darkblue]Next[/color] UqeRow [color=green]'Go back and make another new sheet[/color]
 
Sheets("Sheet1").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]'KaranAdvFiltBodgeCopy()[/color]
[color=green]'[/color]
'

Code again “SHimpfGlified” without comments etc. (If you use this version remember to comment out the Option Explicit Bit at the start of the module):

Sub KaranAdvFiltBodgeCopySHimpfGlified()
Dim ws As Worksheet
 
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then
    ws.Delete
    Else
   
    End If
Next
Application.DisplayAlerts = True
 
     Worksheets.Add(After:=Worksheets(1)).Name = "Unique1"
     LastRecordRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Sheets("Sheet1").Range("A1:A" & LastRecordRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=True
 
 LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 BodgeStartRow = 2
  Dim RangeBodgeRows As Long
  For UqeRow = 2 To LastUnqRow Step 1
   
    If Sheets("Unique1").Cells(UqeRow, 1).Text <> "" Then
     Record = Sheets("Unique1").Cells(UqeRow, 1).Text
     Worksheets.Add(After:=Worksheets(1)).Name = Record
   
      With Sheets("Sheet1")
        .UsedRange.AutoFilter Field:=1, Criteria1:=Record
        .UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Record).Range("A1")
      End With
 
 
  Sheets("Sheet1").AutoFilterMode = False
   LastRecordColumn = Sheets(Record).Cells(2, Columns.Count).End(xlToLeft).Column
   RangeBodgeRows = Sheets(Record).Range("A" & Rows.Count).End(xlUp).Row
   
    Sheets("Sheet1").Range(Sheets("Sheet1").Cells(BodgeStartRow, 1), Sheets("Sheet1").Cells(BodgeStartRow + RangeBodgeRows - 2, LastRecordColumn)).Copy
    Sheets(Record).Range("a2").Select: ActiveSheet.Paste
 
   BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
  Next UqeRow
 
Sheets("Sheet1").AutoFilterMode = False
 
Application.DisplayAlerts = False
Sheets("Unique1").Delete
Application.DisplayAlerts = True
 
End Sub

…

Here is the XL 2007 .xlsm File, Codes in Macro module “Alan”
https://app.box.com/s/cm8ma7jb55z9tx7hb2to
… enable macros…etc.. etc.. I am sure you know wot to do..Note the final results are already there and my code works reasonably fast so you might not thing it does anything.. But it does! ..step through with F8 etc. and you will see that the first thing it does is delete all sheets except sheet 1, then puts them back in WITH FORMULAS!!!

 

[DocAElstein]

.............. So the main thing is to tweak the existing macro to retain the formulas in the original data. .....

Hi Karan..
. I tried to understand your code. I could not fully understand it, but was just about able to see the similarities with mine in order to apply my “Bodge” to your code
.
.
. I am still struggling a bit to understand where the problem lies. – We may have hit on a can of worms here – a never solved problem with VBA Advanced Filter Copy.. Somehow by specifically assigning the Range to be copied, formulas will always be copied, whereas by copying everything that is visible but to the Last Row for all ranges, the formulas are only copied the first time around. That it works the first time around could lie somewhere in the idea that the first range is somehow more similar to a specific range in this case as the first row is the range start row not relying on the visible stuff. But exactly the explanation I cannot understand.
. Nevertheless, thinking along these lines I was able to re modify your code again, this time without Re – Copying, but retaining the “Copy Destination:=” bit, but specifically referring to the range determined from the Initial “Advanced Filter Unique Copy” bit... This second “Bodge” solution is a little bit tidier

Codes bodging Karan’s Sub Staffing_Budget_parse_data():

[color=green]'[/color]
'
[color=darkblue]Sub[/color] Staffing_Budget_parse_data_AlanBodge()
 
[color=darkblue]Dim[/color] lr [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
[color=darkblue]Dim[/color] vcol, i [color=darkblue]As[/color] [color=darkblue]Integer[/color]
[color=darkblue]Dim[/color] icol [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Dim[/color] myarr [color=darkblue]As[/color] [color=darkblue]Variant[/color]
[color=darkblue]Dim[/color] title [color=darkblue]As[/color] [color=darkblue]String[/color]
[color=darkblue]Dim[/color] titlerow [color=darkblue]As[/color] [color=darkblue]Integer[/color]
vcol = 1  [color=green]'set column number[/color]
[color=darkblue]Set[/color] ws = Sheets("Sheet1") [color=green]'set sheet name[/color]
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row [color=green]'last row Sheet 1[/color]
title = "A1:h1"   [color=green]' set title row range as string[/color]
titlerow = ws.Range(title).Cells(1).Row [color=green]' When using only one argument, it must be a number which is an index from right to left then top to bottom., here refers to A1 (the first cell left to right)[/color]
icol = ws.Columns.Count [color=green]'The nimber of columns fo this version of Excel[/color]
ws.Cells(1, icol) = "Unique" [color=green]'Writes Unique in last column row (1)[/color]
[color=green]'  >> I have no idea wot this is doing: it appears to be neccersary..but  it just rewrites in first column wot is already there I think???[/color]
                    [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] lr
                        [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
                        [color=darkblue]If[/color] ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 [color=darkblue]Then[/color]
                        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
                        [color=darkblue]End[/color] [color=darkblue]If[/color]
                    [color=darkblue]Next[/color] i
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) [color=green]'This gives an array of unoque values but i have no idea how.[/color]
ws.Columns(icol).Clear
    [color=darkblue]Dim[/color] BodgeStartRow [color=darkblue]As[/color] Long: BodgeStartRow = 2
    [color=darkblue]Dim[/color] LastRecordColumn [color=darkblue]As[/color] [color=darkblue]Long[/color], RangeBodgeRows [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] [color=darkblue]UBound[/color](myarr) [color=green]'This loop works very similar toi mine, making a new sheet, but based on the unique number from the myarr(i), rather than the tempory sheet of mine[/color]
    ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & "" [color=green]'This does the "Only make bit visible" bit[/color]
    [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then [color=green]'Check to see if sheet is not there[/color]
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    [color=darkblue]Else[/color]
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Destination:=Sheets(myarr(i) & "").Range("A1") [color=green]' The visible bit is copied and sent to new sheet. Copy destination method, but still using Range that is visible. That is to say, although lr is still for the whole range, only what is visible is copied[/color]
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy [color=green]'Copy, - The visible bit is copied...[/color]
    Sheets(myarr(i) & "").Range("A1").Select [color=green]'and selected but....still using...[/color]
    ActiveSheet.Paste [color=green]'.....Auto Filter visible Range[/color]
      
    Sheets(myarr(i) & "").Columns.AutoFit [color=green]'Just bit of tidying up[/color]
 
    [color=green]'ws.AutoFilterMode = False' Does not seem to be important where this is done, that is to say my Bodge below will work the same[/color]
   
        [color=green]'####' So "Alan Bodge Again>> determin dimension of Range fron existing new sheet range.., then copy it again and paste it[/color]
        LastRecordColumn = Sheets(myarr(i) & "").Cells(2, Columns.Count).End(xlToLeft).Column
        RangeBodgeRows = Sheets(myarr(i) & "").Range("A" & Rows.Count).End(xlUp).Row
 
        Sheets("Sheet1").Range(Sheets("Sheet1").Cells(BodgeStartRow, 1), Sheets("Sheet1").Cells(BodgeStartRow + RangeBodgeRows - 2, LastRecordColumn)).Copy
        Sheets(myarr(i) & "").Range("A2").Select: ActiveSheet.Paste
 
        BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
        [color=green]'#### End Bodge[/color]
    [color=darkblue]Next[/color] i
ws.AutoFilterMode = [color=darkblue]False[/color]
ws.Activate
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'Staffing_Budget_parse_data_AlanBodge()[/color]
 
[color=green]'[/color]
'
[color=darkblue]Sub[/color] Staffing_Budget_parse_data_AlanBodge2()
 
[color=darkblue]Dim[/color] lr [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
[color=darkblue]Dim[/color] vcol, i [color=darkblue]As[/color] [color=darkblue]Integer[/color]
[color=darkblue]Dim[/color] icol [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Dim[/color] myarr [color=darkblue]As[/color] [color=darkblue]Variant[/color]
[color=darkblue]Dim[/color] title [color=darkblue]As[/color] [color=darkblue]String[/color]
[color=darkblue]Dim[/color] titlerow [color=darkblue]As[/color] [color=darkblue]Integer[/color]
vcol = 1  [color=green]'set column number[/color]
[color=darkblue]Set[/color] ws = Sheets("Sheet1") [color=green]'set sheet name[/color]
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row [color=green]'last row Sheet 1[/color]
title = "A1:h1"   [color=green]' set title row range as string[/color]
titlerow = ws.Range(title).Cells(1).Row [color=green]' When using only one argument, it must be a number which is an index from right to left then top to bottom., here refers to A1 (the first cell left to right)[/color]
icol = ws.Columns.Count [color=green]'The nimber of columns fo this version of Excel[/color]
ws.Cells(1, icol) = "Unique" [color=green]'Writes Unique in last column row (1)[/color]
[color=green]'  >> I have no idea wot this is doing: it appears to be neccersary..but  it just rewrites in first column wot is already there I think???[/color]
                    [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] lr
                        [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
                        [color=darkblue]If[/color] ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 [color=darkblue]Then[/color]
                        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
                        [color=darkblue]End[/color] [color=darkblue]If[/color]
                    [color=darkblue]Next[/color] i
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) [color=green]'This gives an array of unoque values but i have no idea how.[/color]
ws.Columns(icol).Clear
    [color=darkblue]Dim[/color] BodgeStartRow [color=darkblue]As[/color] Long: BodgeStartRow = 2
    [color=darkblue]Dim[/color] LastRecordColumn [color=darkblue]As[/color] [color=darkblue]Long[/color], RangeBodgeRows [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] [color=darkblue]UBound[/color](myarr) [color=green]'This loop works very similar toi mine, making a new sheet, but based on the unique number from the myarr(i), rather than the tempory sheet of mine[/color]
    ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
    [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then [color=green]'Check to see if sheet is not there[/color]
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    [color=darkblue]Else[/color]
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    [color=darkblue]End[/color] [color=darkblue]If[/color]
   
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Destination:=Sheets(myarr(i) & "").Range("A1") [color=green]' The visible bit is copied and sent to new sheet. Copy destination method, but still using Range that is visible. That is to say, although lr is still for the whole range, only what is visible is copied. Still needed or nothing is there for the next lines to work with!![/color]
        LastRecordColumn = Sheets(myarr(i) & "").Cells(2, Columns.Count).End(xlToLeft).Column
        RangeBodgeRows = Sheets(myarr(i) & "").Range("A" & Rows.Count).End(xlUp).Row
   
   
    ws.Range("A" & BodgeStartRow & ":A" & BodgeStartRow + RangeBodgeRows).EntireRow.Copy Destination:=Sheets(myarr(i) & "").Range("A2")  [color=green]'Copy destination method, but now using a specified Range[/color]
      
        BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
    ws.AutoFilterMode = [color=darkblue]False[/color] [color=green]' Does not seem to be important where this is done, that is to say my Bodge below will work the same[/color]
   
    [color=green]'                    ws.Range("A1:H1").Copy Destination:=Sheets(myarr(i) & "").Range("A1:H1")'Headers: - This is done alreadyas a by product from[/color]
    Sheets(myarr(i) & "").Columns.AutoFit [color=green]'Just bit of tidying up[/color]
    [color=darkblue]Next[/color] i
ws.AutoFilterMode = [color=darkblue]False[/color]
ws.Activate
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'Staffing_Budget_parse_data_AlanBodge2()[/color]

.......................................

. then just to complete the set I did my first Bodge from the Last thread Using the “Copy Destination:=” bit instead.

[color=green]'[/color]
'
[color=darkblue]Sub[/color] KaranAdvFiltBodgeCopy2()
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off.[/color]
[color=green]'On Error GoTo TheEnd 'If anything goes wrong go to the End instead of crashing.[/color]
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wks1 = ThisWorkbook.Worksheets(1) [color=green]'Give abbreviation for first sheet in this all Properties and methoods of Object Worksheet[/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]Dim[/color] ws [color=darkblue]As[/color] Worksheet [color=green]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] ActiveWorkbook.Worksheets [color=green]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
    [color=darkblue]If[/color] ws.Name <> wks1.Name [color=darkblue]Then[/color] [color=green]'Name property here returns name without .xlsm bit on end[/color]
    ws.Delete
    [color=darkblue]Else[/color] [color=green]'Presumably then the worksheet name is That of the first sheet 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 any Sheets / Tabs------------[/color]
 
[color=green]'Add new Worksheets---[/color]
    [color=green]'Make Tempory Sheet[/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]' Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here[/color]
    [color=darkblue]Dim[/color] LastRecordColumn [color=darkblue]As[/color] [color=darkblue]Long[/color]
   
    [color=green]'Let Worksheets.Add(After:=Worksheets(1)).Name = "Unique1" 'Add a Worksheet after the first, named Unique1 for now[/color]
    [color=darkblue]Let[/color] Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Unique1" [color=green]'Add a Worksheet after the last, named Unique1 for now[/color]
    [color=darkblue]Let[/color] LastRecordRow = wks1.Range("A" & Rows.Count).End(xlUp).Row [color=green]'Go to last row in  Column 1, come back up to last entry and get the row there..allows for differnt versions of Excel with different number of rows.[/color]
    [color=green]'          Let LastRecordRow = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Alternative method: You start at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers) - Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
    wks1.Range("A1:A" & LastRecordRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=[color=darkblue]True[/color] [color=green]'Copies entire A Column to first column in sheet2 (Tempory made "Unique1" sheet), The important bit is Unique:=True - that only copies unique Nuimbers[/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(Rows.Count, 1).End(xlUp).Row [color=green]'get last Row from Column 1..[/color]
[color=green]'                     Let LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '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) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
 [color=green]'### get Row Indices for Stupid Bodge[/color]
  [color=darkblue]Dim[/color] BodgeStartRow [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] BodgeStartRow = 2 [color=green]'Start of first range for Re - Copy. Set tohere to just below heading[/color]
  [color=darkblue]Dim[/color] RangeBodgeRows [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Variable for Range Row in New record Shhet[/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=green]'Let Worksheets.Add(After:=Worksheets(1)).Name = Record 'Add new worksheet with Record name[/color]
    [color=darkblue]Let[/color] Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Record
       [color=green]'Copying data to new sheet----[/color]
        wks1.UsedRange.AutoFilter Field:=1, 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]
        wks1.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(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]
        wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'This has been automatically been set to true, so we only see the visible fltered. We could leave this turned on until the end, but for debugging it helps to turn it back onn here, that is to say make entire first sheet visible.[/color]
       [color=green]'-------------------------------------------------[/color]
 
     
      [color=darkblue]With[/color] Worksheets(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=green]'### Copy Bodge[/color]
  [color=darkblue]Let[/color] LastRecordColumn = Worksheets(Record).Cells(2, Columns.Count).End(xlToLeft).Column [color=green]'Start in first Column second row, go to the last column in that row, come back to last entry and get the column number of it. Allows for differet Column numbers but for karan Column H would 'ave done!![/color]
  [color=darkblue]Let[/color] RangeBodgeRows = Worksheets(Record).Range("A" & Rows.Count).End(xlUp).Row [color=green]'Needed range row length (+1) for copy bodge[/color]
  [color=green]' Alternative for above for getting size of range to be copied Let RangeBodgeRows = Worksheets(Record).Range("A1").CurrentRegion.Rows.Count: Let LastRecordColumn = Worksheets(Record).Range("A1").CurrentRegion.Columns.Count[/color]
 
    wks1.Range("A" & BodgeStartRow & ":A" & BodgeStartRow + RangeBodgeRows - 2).EntireRow.Copy Destination:=Sheets(Record).Range("A2") [color=green]'Copy destination method, but now using a specified Range[/color]
 
  [color=darkblue]Let[/color] BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
  [color=darkblue]Next[/color] UqeRow [color=green]'Go back and make another new sheet[/color]
    [color=green]'                    ws.Range("A1:H1").Copy Destination:=Sheets(myarr(i) & "").Range("A1:H1")'Headers: - This is done alreadyas a by product from the Advanced filter copy[/color]
[color=green]'wks1.AutoFilterMode = False'It is more useual to do this here,[/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]'KaranAdvFiltBodgeCopy2()[/color]

. I also tidied everything up a little bit and changed the sheet order to the same as yours.



. Take your pick for now. I will let the thing run through my head a bit. At the end of the day I cannot yet see how to get away from effectively copying twice. (The first time copy using the Advanced filter copies automatically the headings BTW).
. Note also BTW that the bodge only works assuming unique numbers are grouped together, which appears to be your case.

. Alan.

P.s. The File again with all macros in module “Alan” (This time only with the sheet 1 there so you can test the “Bodged” versions of your code).
https://app.box.com/s/cm8ma7jb55z9tx7hb2to

 

[karan1916]

Thanks a lot Alan. I will definitely try the code and let you know the results, but the effort you have put in this is commendable. I didn't realize people can be this helpful. I really appreciate your help on this. Will get back to you soon. Karan

 

[DocAElstein]

… just tidying this last chunk of this thread up a bit from Post #32 as I have a good explanation and solution to the Copying formula problem from Rick at
http://www.mrexcel.com/forum/excel-...ypevisible-copy-only-values-not-formulas.html
.. and in the meantime along the way I now understand that complete program.. So I re-wrote it for my “archives” (Note many things worked in the code from Post #32 only by luck as excel “guessed right” some bits that were missing!. (Unfortunately it was not able to guess right that formulas should be copied!!!!....))

.... So just for completeness I include copies of my final version here....
..First full with my messy explaining comments..

[color=darkblue]Sub[/color] Staffing_Budget_parse_data_AlanJan2015()
 
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/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. Useful to Edit out for Debuging[/color]
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wks1 = ThisWorkbook.Worksheets(1) [color=green]'set sheet name - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet[/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]Dim[/color] ws [color=darkblue]As[/color] Worksheet [color=green]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
        [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] ActiveWorkbook.Worksheets [color=green]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
            [color=darkblue]If[/color] ws.Name <> wks1.Name [color=darkblue]Then[/color] [color=green]'Name property here returns name without .xlsm bit on end[/color]
            ws.Delete
            [color=darkblue]Else[/color] [color=green]'Presumably then the worksheet name is That of the first sheet so[/color]
            [color=green]' do nothing (Don't delete it!)[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] ws
        Application.DisplayAlerts = [color=darkblue]True[/color] [color=green]'Turn it back on[/color]
        [color=green]'End Bit to delete any Sheets / Tabs------------[/color]
 
[color=green]'Some variables used in various places[/color]
[color=darkblue]Dim[/color] vLkUpc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] vLkUpc = 1 [color=green]'set column number 'Column where search criteria for filtering is. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here)[/color]
[color=darkblue]Dim[/color] rws [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Bound variable Row count used in looping[/color]
[color=darkblue]Dim[/color] lr [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
[color=darkblue]Dim[/color] lshtc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lshtc = wks1.Columns.Count [color=green]'Number of Columns in sheet[/color]
[color=darkblue]Dim[/color] lc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lc = wks1.Cells(1, lshtc).End(xlToLeft).Column [color=green]'Last column with entry in heading in Sheet 1. Found by starting at last cell in row 1, then going backwards (ToLeft) until something is found, with .End returning a range from which the column property can be used to get the column number[/color]
[color=green]'--------------------------------------[/color]
 
    [color=green]'make an Array for Unique Search values, using a Tempory column[/color]
    [color=darkblue]Let[/color] wks1.Cells(1, lshtc) = "Unique" [color=green]'The last Column inn the sheet is used. (This has an advantage of not  interfering with our Method for getting lc). hee just for fun we give the array, that is to say the tempory column, a heading[/color]
        [color=darkblue]For[/color] rws = 2 [color=darkblue]To[/color] lr [color=darkblue]Step[/color] 1 [color=green]'Going down all rows  from just after heading in First sheet[/color]
        [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color] [color=green]'Necersary to ensure the looping goes on if the match cannot be determined, as below we have a look Up Array with empty cells[/color]
            [color=darkblue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 [color=darkblue]Then[/color] [color=green]'provided something is there, we check to see if that value is already in our vLook Up Array by looking to see for a match. If it is not there then.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=green]'.....Put  it there[/color]
            [color=darkblue]Else[/color] [color=green]'Else do nothing[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] rws
    Dim myarr() [color=darkblue]As[/color] [color=darkblue]Variant[/color] [color=green]'Array for Unique search criteria. Important to get this Dimensioning right. Variant must be used as below  initially an object is seen...>>  http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues).Value) [color=green]'just a complicated but nice one-liner way of getting just the values and no empty cells in the Array. XlcellTypeConstants just gives constants, the second argument is the type. Here Strings are there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.[/color]
    wks1.Columns(lshtc).Delete [color=green]'Delete the tempory Column (Delete is usually better than Clear.. >>  http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html[/color]
    [color=green]'End of making an Array----------------------------------------[/color]
 
    [color=green]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
        [color=darkblue]For[/color] rws = 2 [color=darkblue]To[/color] [color=darkblue]UBound[/color](myarr) [color=green]'For each unique value in the Array[/color]
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=green]'This blends out everything except  where rows meet our search citeria[/color]
            [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=green]'Check to see if the sheet is there by seeing if the reference to cell A1 in that sheet doesn#t exist. If it is true that it does not exist, then[/color]
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" [color=green]'Make it as that after the last sheet[/color]
            [color=darkblue]Else[/color]
            Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=green]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
   
        [color=green]'.......->>---...Copy Entire row that is visible (Not blended out) to the current sheet in loop[/color]
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=green]'Copy just wot is visible after filtering[/color]
        Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=xlPasteFormulas [color=green]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
        Sheets("" & myarr(rws) & "").Columns.AutoFit [color=green]'Just tidy up a bit[/color]
        [color=darkblue]Next[/color] rws
    [color=green]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
 
wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'re - Blend in everything in sheet 1[/color]
wks1.Activate [color=green]'Activate that sheet 1 just to see it[/color]
 
TheEnd:
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
 
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'Staffing_Budget_parse_data_AlanJan2015()[/color]

….then simplified without comments etc.

Sub Staffing_Budget_parse_data_AlanJan2015shg()
 
Dim wks1 As Worksheet: Set wks1 = ThisWorkbook.Worksheets(1)
Dim rws As Long, vLkUpc As Long: vLkUpc = 1
Dim lr As Long: lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim lshtc As Long: lshtc = wks1.Columns.Count
Dim lc As Long: lc = wks1.Cells(1, lshtc).End(xlToLeft).Column
 
    wks1.Cells(1, lshtc) = "Unique"
        For rws = 2 To lr Step 1
        On Error Resume Next
            If wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 Then
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc)
            End If
        Next rws
    Dim myarr() As Variant
    myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues).Value)
    wks1.Columns(lshtc).Delete
 
        For rws = 2 To UBound(myarr)
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & ""
            If Not Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & ""
            Else
            Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count)
            End If
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy
        Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=xlPasteFormulas
        Sheets("" & myarr(rws) & "").Columns.AutoFit
        Next rws
 
wks1.AutoFilterMode = False
End Sub

.. returned file…(XL 2007 .xlsm Newest macros in Module “KaransFinal”
https://app.box.com/s/tzzxyuexlopj4q5nhcbpi59gg7yvf4vs



………………………

Alan….