VBA: Split data into multiple worksheets based on column

W

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:
Sort by date Sort by votes
Ken_W said:
.......e (your #38 post). However, it only works based on column A. I saw other versions of code where this could be modified but was not able to get it to work for me due to my limited understanding of what I am doing. I need it to work as is but based on column F in my file. ........................

As you’ll see, I am working with a lot of data and this is only a small portion. I suspect I’ll be limited in the amount of rows I can do at one time. I’ve seen some of your post where you mention too much data being a problem. I greatly appreciate any assistance you can provide.

Ken
Click to expand...

Hi Ken,
That is a weird File - It just took my computer 20 minutes to download it., and about the same to open it.

. But it aint much bigger than some files I have which take a few seconds. ( yours has, I think about 6078 rows?? ) ,?? So I am a bit nervous about opening any macros that are in it

. I think I wrote the code to be fairly flexible, but it is a while back now. Usually I use a variable for the “LookUpColumn” ….
.. Looking just now at the FINAL version of the code you mentioned (which is in Post #40, not post #38 )
.. – I think I see that variable as assigned to the column 1 as vLkUpc = 1 somewhere near the start, and clearly commented :

Let vLkUpc = 1 'set column number 'Column where search criteria for filtering is.

.... Maybe that is all you need to do??

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


. I am a pat time novice myself and just do not have the experience of real life files. Until now the feedback was that the code worked with Big “Normal “ data, but exactly how big “Big” was not asllways sure...…. Although here for example.
http://www.mrexcel.com/forum/excel-...-into-multiple-worksheets-based-column-3.html
Post # 27 the OP, Joeyc said my code worked for 350,000 Rows!!!
-
. Not sure if I want to spend much time later with that weird file-- … Not sure if it my wee little Computer might explode!!!.. very weird it takes so ling to open or save ???

. My advice at this stage would be if the simpe vLkUpc mod don't work, .. then make a drastically shortened version of your file, but keeping the data representatives to cover all scenarios. Then try again my code from #40 bearing in mind the vLkUpc = 1 should then be vLkUpc = 6 (A is 1 ….. F is 6 - get it? )
. See how you get on then get back to me if you have problems. I have a few of these sort of codes kicking about in Threads….. to name a few I can remember:


Copying a row from a worksheet to multiple new sheets depending on the word in the column
vba to copy value and paste in worksheet with the same name as value
Copy entire row to another worksheet if column = specific value
VBA: Split data into multiple worksheets based on column
Copy entire row to another worksheet if column = specific value
Copying a Row Based on Coloumn Contents
VBA code for Grouping columns in excel based on certain criteria
http://www.mrexcel.com/forum/excel-...et-multiple-excel-files-name-cell-column.html
……..)


… maybe check out them as well…

. if you still can’t get any to work for you drop me off a shortened file, say exactly wot you want your output to look after running the macro based on the shortened data you send, - I will get that working for you, then we will take it from there. Might have to be tomorrow or then From Sunday. So in the meantime keep at it, keep me informed and drop off the info.. ( or maybe someone else will pop by and give it a shot… )

Alan


P.s. Welcome to the Board
 
Last edited:
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Alan,

Thank you for the quick response. I admit, I think I did pull your final code from #40, with comments. I got confused after looking at so much.

I swear I changed the Let vLkUpc = 1 to equal 6, but now it is working. I don’t know. But glad to hear the delay in opening is a problem. I was concerned with that as well.

I created a new file, copy/pasted my data into it and it opens fairly quickly now so don’t know about that either.

I’ll have to revisit this Monday. But wanted to say thanks!
 
Upvote 0
Ken_W said:
..
Thank you for the quick response. ..
..!
Click to expand...
Yous welcome, thanks for the Feedback.

Ken_W said:
.. glad to hear the delay in opening is a problem. I was concerned with that as well… created a new file, copy/pasted my data into it and it opens fairly quickly now so don’t know about that either…!
Click to expand...

.. yep weird one, but worth keeping the file to play a trick on a colleague if you want to ties his computer up a while..

Ken_W said:
……
I created a new file, copy/pasted my data into it and it opens fairly quickly now so don’t know about that either. …
Click to expand...

. that is exactly where I would probably have started…..
… Glad the code worked then. Get back if you need more help. – I was learning as I wrote those codes, I ‘ave a better idea how they work now.

Alan.
 
Upvote 0
Hello Dears
I'm new here and i need some help
I used split data based on column Vba codes
But i need to split data for every sheets A,B,C column not entire column.How can I change this?
Pls someone help me
Thanks
 
Upvote 0
Hello Dears
I'm new here and i need some help
I used split data based on column <acronym title="visual basic for applications">Vba</acronym> codes
But i need to split data for every sheets A,B,C column not entire column.How can I change this?
ws.Range("a" & titlerow & ":a" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A3")
Sheets(myarr(i) & "").Columns.AutoFit
I think i need to change Entirerow.copy
And changed this Columns(3) But only copied C column
I must populate first three columns
Pls someone help me
Thanks
 
Upvote 0
emperorlord said:
Hello Dears........
But i need to split data for every sheets A,B,C column not entire column.How can I change this?
ws.Range("a" & titlerow & ":a" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A3")
Sheets(myarr(i) & "").Columns.AutoFit
I think i need to change Entirerow.copy
And changed this Columns(3) But only copied C column
I must populate first three columns
........
Click to expand...


Dearest “emperorlord”!..

Welcome to the Board!

. It is very difficult to give you an exact solution without seeing your full code and having some sample data showing what you have and what you want to achieve .....
.

. I have so many codes in this Thread that I confess I have lost track a bit: But I do not think you are using one of my codes???

. But anyway I just experimented a bit with one of my codes and got it to only copy Columns A – C rather than the Entire Row: ( The line shown in orange did the trick for my code )

Code: 
        [color=lightgreen]'.......->>---...Copy Entire rows or columns of range that is visible (Not blended out) to the current sheet in loop[/color]
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=lightgreen]'Copy just wot is visible after filtering. To Copy EntireRow any or more of the  ENTIRE columns can be selected in initial Range which is then mofified[/color]
        wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=lightgreen]' first by .SpecialCells(xlCellTypeVisible) Method and then by EntireRow Property[/color]
        wks1.Range("G" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=lightgreen]' Important is only that lr is used, or rather entire virtical range[/color]
        wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 1 & ":H" & lr & "").Copy [color=lightgreen]'Alternative way of selecting Entire Range[/color]
        wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).Copy [color=lightgreen]'Will also work for Entire Row !![/color]
        [color=orange]wks1.Range("A" & 1 & ":B" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 1 & ":C" & lr & "").Copy[/color] [color=lightgreen]'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like[/color]
        Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=xlPasteFormulas [color=lightgreen]'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=lightgreen]'Just tidy up a bit[/color]
        [color=blue]Next[/color] rws
    [color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
.................................
. It would be more tricky if you wanted to copy non consecutive rows
. At the end of the day it is all a case of how you access your range. – So I will attempt to answer specifically your question :
. 1 ) Initially the first Range Object in your case:
ws.Range("a" & titlerow & ":a" & lr)
should include at least column A, as it does. So that bit is fine.
. 2 ) Then instead of modifying it with the EntireRow Property you should modify it with a Range Property which “going out” from the Range Object, accesses and therefore modifies your Range Object to the part of the initial Range you require.

. Putting that in English: -
. ... I would guess that in your case the modified code line you require would look like this:

ws.Range("a" & titlerow & ":a" & lr).Range("a" & titlerow & ":c" & lr).Copy Sheets(myarr(i) & "").Range("A3")

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

.
. The bottom line is that it is all about understanding Range Referencing in VBA, - Here a couple of links that may help:
Referring to Ranges in VBA | Excel Matters
Range Dimensioning, Range and Value Referencing and Referring to Arrays [SOLVED] - Page 5

Ciao
Alanso Elston

( P.s. . It would be more tricky if you wanted to copy non consecutive rows such as A and C but not B. It would be interesting to know if any Pro coincidentally catching this Post could give the code line for your or my code for doing that. Probably involves some “Union” – ing of individual ranges ? )
 
Last edited:
Upvote 0
Thank you for your fast response DocAElstein
It's really nice. It's copied Copied data A:C column
Let me explain my workbook It is accounting receivable report. It has individual sheet for each customers.
I wanted automatically copy A,B,C columns which is Date ,Comment, Sales.You already helped this:)
But i have another problem. When customer paid the money i must manually date and put the amount and paid for which banks
When i add another data on the data sheet and run the macro it is erase my information (for example in this workbooks 10612422 sheet marked blue row i manually added.
I add data on data sheet and run the macro it is blue marked row erased)
My answer is how can i add data below blue marked data I think it is possible for your macro. Because last row function must work
Sorry for my bad english:) I attached file below
And i used your that code
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        'CHANGE THE COLUMN NUMBER AS PER YOUR NEED

Set ws = Sheets("data")        'CHANGE THE SHEET NAME AS PER YOUR NEED

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:z1"             'CHANGE THE TITLE ROW AS PER YOUR NEED
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).Range("a" & titlerow & ":c" & lr).Copy Sheets(myarr(i) & "").Range("A3")
Sheets(myarr(i) & "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate

End Sub
https://onedrive.live.com/redir?resid=E209846DBCD9B740!127&authkey=!ADMsmnuhT17VNNE&ithint=file,xlsm
 
Last edited by a moderator:
Upvote 0
Hi emperorlord,
. I think the code You are using comes from here:
How to split data into multiple worksheets based on column in Excel?
… and / or Post # 32 from this Thread
… and / or Post # 41 from this Thread?
... They are NOT codes from me!
...................

. I took that basic code, improved it, and did a version for karan1916 in this Thread. My final version is to be found in Post # 40 of this Thread. I would prefer to use that code as I am familiar with it.
...........................

. If I am able to help you further and with your new requirement from Post # 97 , I would prefer to start at my full modified code found in Post # 40. I could then simplify that code and possible modify it for your new requirement from Post # 97
.
. Initially I have modified it only to meet your initial requirement from Posts #94 and Post #95.
. I return the modified file to you. I attached the file here .
https://app.box.com/s/w49v0h098vwxds29b6tm6wdc7lwdnsgs
.
. Please examine that file and run the code “emperorlord_parse_data_AlanJuli2015_1()”
. Please confirm that it meets your initial requirements. It appears to me to do the same as your code “parse_data()”
.
. Initially I am assuming your original data sheet looked like this:

Using Excel 2007
-
A​
B​
C​
D​
E​
F​
G​
1​
Date​
Comment​
Sales​
Date difference​
Payment​
Receivable​
2​
25.06.2015​
89032​
1000000​
10612422​
3​
26.06.2015​
89033​
183117​
10611201​
4​
27.06.2015​
89034​
182223​
10612532​
5​
28.06.2015​
89035​
156576​
10014016​
6​
29.06.2015​
89036​
162924​
10612530​
7​
30.06.2015​
89037​
128667​
10412127​
8​
01.07.2015​
89038​
104142​
10613004​
9​
01.07.2015​
89039​
132660​
10611201​
10​
01.07.2015​
89040​
186861​
10611201​
11​
01.07.2015​
89041​
167570​
10611201​
12​
01.07.2015​
89042​
187077​
10611201​
13​
01.07.2015​
89043​
129179​
10611201​
14​
25.06.2015​
89032​
1000000​
10612422​
15​
25.06.2015​
89032​
1000000​
10612422​
16​
25.06.2015​
89032​
1000000​
10612422​
17​
25.06.2015​
89032​
1000000​
10612422​
18​
25.06.2015​
89032​
1000000​
10612422​
19​
25.06.2015​
89032​
1000000​
10612422​
20​
25.06.2015​
89032​
1000000​
10612422​
21​

<tbody>
</tbody>
Data

<tbody>
</tbody>
........

. After running my code, this would be just 2 examples of some of the sheets it creates:

Using Excel 2007
-
A​
B​
C​
D​
E​
F​
G​
3​
Date​
Comment​
Sales​
Date difference​
Payment​
Receivable​
4​
25.06.2015​
89032​
1000000​
5​
25.06.2015​
89032​
1000000​
6​
25.06.2015​
89032​
1000000​
7​
25.06.2015​
89032​
1000000​
8​
25.06.2015​
89032​
1000000​
9​
25.06.2015​
89032​
1000000​
10​
25.06.2015​
89032​
1000000​
11​
25.06.2015​
89032​
1000000​

<tbody>
</tbody>
10612422

<tbody>
</tbody>


Using Excel 2007
-
A​
B​
C​
D​
E​
F​
G​
3​
Date​
Comment​
Sales​
Date difference​
Payment​
Receivable​
4​
26.06.2015​
89033​
143854​
5​
01.07.2015​
89039​
186455​
6​
01.07.2015​
89040​
140238​
7​
01.07.2015​
89041​
123755​
8​
01.07.2015​
89042​
147387​
9​
01.07.2015​
89043​
107038​

<tbody>
</tbody>
10611201

<tbody>
</tbody>


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

. With regards to your new requirement, from Post #97 –
emperorlord said:
……
But i have another problem. When customer paid the money I must manually date and put the amount and paid for which banks
When i add another data on the data sheet and run the macro it is erase my information (for example in this workbooks 10612422 sheet marked blue row i manually added.
I add data on data sheet and run the macro it is blue marked row erased)
My answer is how can i add data below blue marked data I think it is possible for your macro. Because last row function must work…..
Click to expand...

. This will be very difficult if you simply add data to the data sheet. This is because there is no way to distinguish between the new and old data. Clearly then, as you saw, the current codes simply paste the entire data. Until you decide how to do this, I see no way that any code would know how to distinguish between new and old data
.
. A couple of possibilities:
. 1 ) You need to delete the old data and just have the new data in sheet “data” before each run with new data. That would probably be the easiest.

Using Excel 2007
-
A​
B​
C​
D​
1​
Date​
Comment​
Sales​
Date difference​
2​
25.06.2015​
89032​
1000000​
10612422​
3​
25.06.2015​
89032​
1000000​
10612422​
4​
25.06.2015​
89032​
1000000​
10612422​
5​
25.06.2015​
89032​
1000000​
10612422​
6​
25.06.2015​
89032​
1000000​
10612422​
7​
25.06.2015​
89032​
1000000​
10612422​
8​
25.06.2015​
89032​
1000000​
10612422​
9​
25.06.2015​
89032​
1000000​
10612422​
10​
25.06.2015​
89032​
1000000​
10612422​
11​
25.06.2015​
89032​
1000000​
10612422​
12​
25.06.2015​
89032​
1000000​
10612422​

<tbody>
</tbody>
Data

<tbody>
</tbody>

. 2) Somehow you must identify your new data, such as by a an empty row

Using Excel 2007
-
A​
B​
C​
D​
1​
Date​
Comment​
Sales​
Date difference​
2​
25.06.2015​
89032​
1000000​
10612422​
3​
26.06.2015​
89033​
182266​
10611201​
4​
27.06.2015​
89034​
186993​
10612532​
5​
28.06.2015​
89035​
187206​
10014016​
6​
29.06.2015​
89036​
130643​
10612530​
7​
30.06.2015​
89037​
130064​
10412127​
8​
01.07.2015​
89038​
169348​
10613004​
9​
01.07.2015​
89039​
124659​
10611201​
10​
01.07.2015​
89040​
169907​
10611201​
11​
01.07.2015​
89041​
105020​
10611201​
12​
01.07.2015​
89042​
185455​
10611201​
13​
01.07.2015​
89043​
125771​
10611201​
14​
25.06.2015​
89032​
1000000​
10612422​
15​
25.06.2015​
89032​
1000000​
10612422​
16​
25.06.2015​
89032​
1000000​
10612422​
17​
25.06.2015​
89032​
1000000​
10612422​
18​
25.06.2015​
89032​
1000000​
10612422​
19​
25.06.2015​
89032​
1000000​
10612422​
20​
25.06.2015​
89032​
1000000​
10612422​
21​
22​
25.06.2015​
89032​
1000000​
10612422​
23​
25.06.2015​
89032​
1000000​
10612422​
24​
25.06.2015​
89032​
1000000​
10612422​
25​
25.06.2015​
89032​
1000000​
10612422​
26​
25.06.2015​
89032​
1000000​
10612422​
27​
25.06.2015​
89032​
1000000​
10612422​
28​
25.06.2015​
89032​
1000000​
10612422​
29​
25.06.2015​
89032​
1000000​
10612422​
30​
25.06.2015​
89032​
1000000​
10612422​
31​
25.06.2015​
89032​
1000000​
10612422​
32​
25.06.2015​
89032​
1000000​
10612422​

<tbody>
</tbody>
Data

<tbody>
</tbody>

. The codes could then be modified appropriately to meet your new requirements. The modifications would involve careful manipulating of the copied Range. Not difficult, but possibly a somewhat time consuming excessive.

Alan

. My initial Code, and your last Code ( Both in the returned file ):

Code: 
[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=blue]Sub[/color] emperorlord_parse_data_AlanJuli2015_1()
 
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'set sheet name - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet ( For first sheet : Set wks1 = ThisWorkbook.Worksheets(1) )[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'  turn off the AutoFilters[/color]
        [color=lightgreen]'Start Bit to  Delete Sheets / Tabs------------[/color]
        Application.DisplayAlerts = [color=blue]False[/color] [color=lightgreen]'Prevents being asked everytime if you really want to delete the Workbook[/color]
        [color=blue]Dim[/color] ws [color=blue]As[/color] Worksheet [color=lightgreen]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
        [color=blue]For[/color] [color=blue]Each[/color] ws [color=blue]In[/color] ActiveWorkbook.Worksheets [color=lightgreen]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
            [color=blue]If[/color] ws.Name <> "ASheetToKeep" And ws.Name <> wks1.Name And ws.Name <> "AR Report" And ws.Name <> "101206" [color=blue]Then[/color] [color=lightgreen]'Name property here returns name without .xlsm bit on end[/color]
            ws.Delete
            [color=blue]Else[/color] [color=lightgreen]'Presumably then the worksheet name is That of the first sheet so[/color]
            [color=lightgreen]' do nothing (Don't delete it!)[/color]
            [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] ws
        Application.DisplayAlerts = [color=blue]True[/color] [color=lightgreen]'Turn it back on[/color]
        [color=lightgreen]'End Bit to delete any Sheets / Tabs------------[/color]
 
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 4 [color=lightgreen]'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=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping[/color]
[color=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'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=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(1, lshtc).End(xlToLeft).Column [color=lightgreen]'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=lightgreen]'--------------------------------------[/color]
 
    [color=lightgreen]'make an Array for Unique Search values, using a Tempory column[/color]
    [color=blue]Let[/color] wks1.Cells(1, lshtc) = "Unique" [color=lightgreen]'The last Column inn the sheet is used. (This has an advantage of not  interfering with our Method for getting lc). here just for fun we give the array, that is to say the tempory column, a heading[/color]
        [color=blue]For[/color] rws = 2 [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows  from just after heading in First sheet[/color]
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'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=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 [color=blue]Then[/color] [color=lightgreen]'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 there we go to else.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=lightgreen]'.....Put  it there[/color]
            [color=blue]Else[/color] [color=lightgreen]'Else do nothing - we already had a match[/color]
            [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] rws
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] 0 [color=lightgreen]'Disable the above Error handler[/color]
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the default error handler for unpredictable errors[/color]
    Dim myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this [color=blue]Dim[/color]ensioning 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, xlNumbers).Value) [color=lightgreen]'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 (xlTextValues) would be 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. We want xlNumbers. 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=lightgreen]'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=lightgreen]'End of making an Array----------------------------------------[/color]
 
    [color=lightgreen]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
        [color=blue]For[/color] rws = 1 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'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=lightgreen]'This blends out everything except  where rows meet our search citeria[/color]
            [color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'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=lightgreen]'Make it as that after the last sheet[/color]
            wks1.Range("A1").EntireRow.Copy
            Worksheets("" & myarr(rws) & "").Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
            [color=blue]Else[/color]
            Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=blue]End[/color] [color=blue]If[/color]
   
        [color=lightgreen]'.......->>---...Copy Entire rows or columns of range that is visible (Not blended out) to the current sheet in loop (Note: by default ommiting .SpecialCells(xlCellTypeVisible) also works![/color]
       
        wks1.Range("A" & 1 & ":B" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 2 & ":C" & lr & "").Copy [color=lightgreen]'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like[/color]
        Worksheets("" & myarr(rws) & "").Range("A4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats [color=lightgreen]'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=lightgreen]'Just tidy up a bit[/color]
        [color=blue]Next[/color] rws
    [color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
 
 
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
 
TheEnd: [color=lightgreen]'Come Here for unexpected errors and do anything that should be done before ending program[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 -  turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen flicker after Copy Paste (clear the Clipboard.)[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'emperorlord_parse_data_AlanJuli2015_1()Sub emperorlord_parse_data_AlanJuli2015_1()[/color]
 
 
 
[color=blue]Sub[/color] parse_data()
 
[color=blue]Dim[/color] lr [color=blue]As[/color] [color=blue]Long[/color]
[color=blue]Dim[/color] ws [color=blue]As[/color] Worksheet
[color=blue]Dim[/color] vcol, i [color=blue]As[/color] [color=blue]Integer[/color]
[color=blue]Dim[/color] icol [color=blue]As[/color] [color=blue]Long[/color]
[color=blue]Dim[/color] myarr [color=blue]As[/color] [color=blue]Variant[/color]
[color=blue]Dim[/color] title [color=blue]As[/color] [color=blue]String[/color]
Dim titlerow [color=blue]As[/color] [color=blue]Integer[/color]
 
vcol = 4        [color=lightgreen]'CHANGE THE COLUMN NUMBER AS PER YOUR NEED[/color]
 
[color=blue]Set[/color] ws = Sheets("data")        [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED[/color]
 
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
 
title = "A1:z1"             [color=lightgreen]'CHANGE THE TITLE ROW AS PER YOUR NEED[/color]
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
 
ws.Cells(1, icol) = "Unique"
 
[color=blue]For[/color] i = 2 [color=blue]To[/color] lr
[color=blue]On[/color] Error [color=blue]Resume[/color] [color=blue]Next[/color]
[color=blue]If[/color] ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 [color=blue]Then[/color]
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color]
 
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
 
ws.Columns(icol).Clear
 
[color=blue]For[/color] i = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr)
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
 
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
[color=blue]Else[/color]
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
[color=blue]End[/color] [color=blue]If[/color]
ws.Range("a" & titlerow & ":a" & lr).Range("a" & titlerow & ":c" & lr).Copy Sheets(myarr(i) & "").Range("A3")
Sheets(myarr(i) & "").Columns.AutoFit
[color=blue]Next[/color]
 
ws.AutoFilterMode = [color=blue]False[/color]
ws.Activate
 
[color=blue]End[/color] [color=blue]Sub[/color]
 
Last edited:
Upvote 0
Dear DocElstein
Thank you for your help. I think i must use your previous code. You helped me a lot. Have a nice day Thank you again
 
Upvote 0
Hi emperorlord,
emperorlord said:
Dear DocElstein
Thank you for your help. I think i must use your previous code. You helped me a lot. Have a nice day Thank you again
Click to expand...
. Your welcome.
. Good luck with your project

Alan Elston

'
'
'
'
'
'
'
'
'
'
'
'
P.s. As it is the 100th Post in this thread, and as I am away from the Board after tomorrow... To round it all off with a few codes..... giving 2 main improvements on the basic code idea of this thread..

. 1) The following codes, all basically the same will allow copying rows of any combination of columns in any order from a data sheet based on a column value...

. 2) The data file can be updated after the initial run and then the same code run again to update the sheets already created by the first run, and if necessary creating extra sheets if required....


. As the start point for many people hitting this Threads seems to be the code referenced in Post # 1
Parse_data
, then the first (simplified version ) of my three codes given is stripped down to the minimum to match as closely as possible that Code. ( .... code found from
How to split data into multiple worksheets based on column in Excel?
… and Post # 32 from this Thread
… and Post # 41 from this Thread?
... and post # 97 from this thread ).

( . The first code is not much good but the other two are much better and explained in detail in the green comments. )


. The following results are based on the second code, but results are similar for the others. They are set to copy columns B and A only ( in that order ).

. At the point before running any of the three programs, the first data sheet looks like this ( And there are no other sheets )

Using Excel 2007
-
A​
B​
C​
D​
E​
F​
1​
Date​
Comment​
Sales​
LookUpSheet​
Payment​
Receivable​
2​
25.06.2015​
F-Tang
1000000​
Ha1
3​
26.06.2015​
F-Tang
169624​
Ha2
4​
27.06.2015​
OLE
103347​
Ha3
5​
28.06.2015​
Wiggy-
135467​
Ha2
6​
29.06.2015​
Wam
186021​
Ha1
Data
.........

After running a code the first sheet is modified so:

Using Excel 2007
-
A​
B​
C​
D​
E​
F​
1​
Date​
Comment​
Sales​
LookUpSheet​
Payment​
Receivable​
2​
25.06.2015​
F-Tang
1000000​
Ha1
3​
26.06.2015​
F-Tang
155278​
Ha2
4​
27.06.2015​
OLE
135753​
Ha3
5​
28.06.2015​
Wiggy-
170486​
Ha2
6​
29.06.2015​
Wam
101172​
Ha1
7​
Date​
Comment​
Sales​
LookUpSheet​
Payment​
Receivable​
Data


..... and in addition 3 new sheets are made , ( Assuming only columns B and A ) are required


Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
25.06.2015​
F-Tang
5​
29.06.2015​
Wam
6​
Ha1
.

Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
26.06.2015​
F-Tang
5​
28.06.2015​
Wiggy-
6​
Ha2
.

Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
27.06.2015​
OLE
5​
Ha3

..............................................................
. Now, assuming new data is tacked on to the data sheet thus

Using Excel 2007
-
A​
B​
C​
D​
E​
1​
Date​
Comment​
Sales​
LookUpSheet​
Payment​
2​
25.06.2015​
F-Tang
1000000​
Ha1
3​
26.06.2015​
F-Tang
129684​
Ha2
4​
27.06.2015​
OLE
190417​
Ha3
5​
28.06.2015​
Wiggy-
176856​
Ha2
6​
29.06.2015​
Wam
192675​
Ha1
7​
Date​
Comment​
Sales​
LookUpSheet​
Payment​
8​
02.07.2015​
Du Wolly
114042​
Ha1
9​
03.07.2015​
Wop
182631​
Ha2
10​
01.07.2015​
Barrel
117619​
Ha4
11​
Data

. And the same code run again, then the first two sheets are changed thus

Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
25.06.2015​
F-Tang
5​
29.06.2015​
Wam
6​
02.07.2015​
Du Wolly
7​
Ha1

Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
26.06.2015​
F-Tang
5​
28.06.2015​
Wiggy-
6​
03.07.2015​
Wop
7​
Ha2

.... and in addition a forth sheet is created:

Using Excel 2007
-
A​
B​
C​
2​
3​
Date​
Comment​
4​
01.07.2015​
Barrel
5​
Ha4

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


Codes:

Code: 
[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=lightgreen]'[/color]
[color=blue]Sub[/color] parse_Wind_AlanJuli2015()
 
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color], lr [color=blue]As[/color] Long: lr = wks1.Cells(Rows.Count, 1).End(xlUp).Row
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] [color=blue]Long[/color], lshtc [color=blue]As[/color] Long: lshtc = wks1.Columns.Count
[color=blue]Dim[/color] clmsOut [color=blue]As[/color] Range, Dataclm1 [color=blue]As[/color] Range, Heading [color=blue]As[/color] [color=blue]String[/color], nr [color=blue]As[/color] [color=blue]Long[/color]
[color=lightgreen]'--------------------------------------[/color]
 
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE TITLE ROW AS PER YOUR NEED[/color]
[color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(rngTitle.Column), wks1.Rows("" & rngTitle.Row & ":" & lr & ""))
Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value
nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
[color=lightgreen]'End of determining Required referrence ranges[/color]
 
[color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
wks1.Cells(1, lshtc) = Heading
[color=blue]For[/color] rws = nr [color=blue]To[/color] lr
    [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color]
        [color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color]
        wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc)
        [color=blue]End[/color] [color=blue]If[/color]
    [color=blue]Next[/color] rws
[color=blue]Dim[/color] myarr() [color=blue]As[/color] Variant: myarr() = Application.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants).Value)
wks1.Columns(lshtc).Delete
[color=lightgreen]'End of making an Array----------------------------------------[/color]
 
   
[color=lightgreen]'Make a New worksheet if necerssary, copy data to new or already there sheets[/color]
 [color=blue]Dim[/color] ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range
 [color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr)
    rngTitle.AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & ""
        [color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then
        ld = 1: Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & ""
        [color=blue]Else[/color]
        Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count)
        ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1
        End [color=blue]If[/color]
    [color=lightgreen]'Copy to sheet[/color]
    [color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr - 1 & ":" & lr & ""), clmsOut) '
    rngCopy.SpecialCells(xlCellTypeVisible).Copy Worksheets("" & myarr(rws) & "").Range("A" & ld & "")
    [color=blue]Next[/color] rws
[color=lightgreen]'[color=blue]End[/color] making (if necerssary) new sheet and copying filtered rows to it[/color]
 
wks1.AutoFilterMode = [color=blue]False[/color]
rngTitle.Copy Intersect(wks1.Columns(rngTitle.Column), wks1.Rows("" & lr + 1 & ""))
End [color=blue]Sub[/color] [color=lightgreen]'Alan Passing Wind[/color]
 
[color=lightgreen]'[/color]
'
'
'
'
'
[color=lightgreen]'[/color]
'
'
'
[color=lightgreen]'[/color]
'
 
[color=blue]Sub[/color] parse_data_AlanJuli2015()
 
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
 
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet ( For first sheet : Set wks1 = ThisWorkbook.Worksheets(1) )[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'  turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping  '( 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=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'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=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet. Used for tempory Unique Range. Good idea to set to last column as this will not upset the determination of last column based on a Range.End(xltoleft) Property[/color]
[color=lightgreen]'--------------------------------------[/color]
 
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED 'Column where search criteria for filtering is.[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE HEADING ROW AS PER YOUR NEED[/color]
[color=blue]Dim[/color] sr [color=blue]As[/color] Long: [color=blue]Let[/color] sr = rngTitle.Row [color=lightgreen]'Initially sr is Upper Heading row[/color]
[color=blue]Dim[/color] sc [color=blue]As[/color] Long: [color=blue]Let[/color] sc = rngTitle.Column [color=lightgreen]'Left most column of Heading Row[/color]
[color=blue]Dim[/color] clmsOut [color=blue]As[/color] Range: [color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=blue]Dim[/color] rngTitleOut [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitleOut = Application.Intersect(rngTitle, clmsOut) [color=lightgreen]'Creat new range by slices of Initial Full Title range[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(sr, lshtc).End(xlToLeft).Column [color=lightgreen]'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=blue]Dim[/color] Dataclm1 [color=blue]As[/color] Range: [color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(sc), wks1.Rows("" & sr & ":" & lr & "")) [color=lightgreen]'Returns the Left most column of data[/color]
[color=blue]Dim[/color] Heading [color=blue]As[/color] String: [color=blue]Let[/color] Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value [color=lightgreen]'This is the heading in the Look Up Column, coming from the Value in the intersect of the Look Up Column and the Title Range Row[/color]
Dim nr [color=blue]As[/color] Long: [color=blue]Let[/color] nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 [color=lightgreen]'Detertmine start of New Data. Start at cell in arbritrary column, then go backwards and when heading found, get row +1 for start of new data[/color]
[color=lightgreen]'End of determining Required referrence ranges[/color]
   
[color=lightgreen]'        'Optional Start Bit to  Delete Sheets / Tabs------------[/color]
[color=lightgreen]'        Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=lightgreen]'        [color=blue]Dim[/color] ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=lightgreen]'        For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=lightgreen]'            If ws.Name <> "ASheetToKeep" And ws.Name <> "Data" And ws.Name <> wks1.Name And ws.Name <> "AR Report" And ws.Name <> "101206" Then 'Name property here returns name without .xlsm bit on end[/color]
[color=lightgreen]'            ws.Delete[/color]
[color=lightgreen]'            Else 'Presumably then the worksheet name is That of the first sheet so[/color]
[color=lightgreen]'            ' do nothing (Don't delete it!)[/color]
[color=lightgreen]'            End If[/color]
[color=lightgreen]'        Next ws[/color]
[color=lightgreen]'        Application.DisplayAlerts = True 'Turn it back on[/color]
[color=lightgreen]'        'End Bit to delete any Sheets / Tabs------------[/color]
   
    [color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
    [color=blue]Let[/color] wks1.Cells(1, lshtc) = Heading [color=lightgreen]'The last Column inn the sheet is used. (This has an advantage of not  interfering with our Method for getting lc). We give the array, that is to say the tempory column, a heading. Chosing the heading of the lookUpColumn is a neat trick : myarr will only ( uniquely ) stor it once at the top, and this will be neglected in the looping for sheet namnes[/color]
        [color=blue]For[/color] rws = nr [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows  from just after heading in First sheet[/color]
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'Necersary to ensure carry on after error line if the match row cannot be determined, if below it is not there yet[/color]
            [color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]'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 row. If it is there ( but not at a row of -1234 ! - a valid long number, but position that will never be found, )  we go to else.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=lightgreen]'.....we come here if match errored, so it was not to be found, so we put it there ![/color]
            [color=blue]Else[/color] [color=lightgreen]'Else do nothing - we had a match position. Redundant Code[/color]
            [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] rws
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] 0 [color=lightgreen]'Disable the above Error handler[/color]
        [color=blue]On[/color] Error [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the default error handler for unpredictable errors[/color]
    Dim myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this [color=blue]Dim[/color]ensioning 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).Value)  [color=lightgreen]'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 (xlTextValues) would be 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=lightgreen]'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=lightgreen]'End of making an Array----------------------------------------[/color]
 
   
    [color=lightgreen]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
     Dim ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range [color=lightgreen]'Variable for last data entry in sheet, modified range to be copied from first sheet based on COLUMNS wanted[/color]
        [color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'For each unique value in the Array'From 2 removes the heading.[/color]
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=lightgreen]'This blends out everything except  where rows meet our search citeria[/color]
            [color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'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=lightgreen]'Make it as that after the last sheet[/color]
            rngTitleOut.Copy [color=lightgreen]'Headings range[/color]
            Worksheets("" & myarr(rws) & "").Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
            [color=blue]Else[/color]
            Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=blue]End[/color] [color=blue]If[/color]
   
        [color=lightgreen]'.......->>---...Copy Entire rows or columns required of range that is visible (Not blended out) to the current sheet in loop (Note: by default ommiting .SpecialCells(xlCellTypeVisible) also works![/color]
        [color=blue]Let[/color] ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1 [color=lightgreen]'The Range Object last Cell in the sheet in column 1 has the property .End(with argument "looking Up" ) applied to return a new range ( cell) which is that of the last entry. To this cell the Property .Row is applied to give the row of that cell. +1 to get next row ( start of new data )[/color]
        [color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr & ":" & lr & ""), clmsOut) [color=lightgreen]'Returns Range object based on intersection of rows and columns needed: Rows are those of new data , columns are USER selected[/color]
        [color=lightgreen]'Dataclm1.SpecialCells(xlCellTypeVisible).Range("A" & nr & ":C" & lr & "").Copy 'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like. Only the new data is copied by virtue of the use of nr[/color]
        rngCopy.SpecialCells(xlCellTypeVisible).Copy [color=lightgreen]'This will copy the visible part, that is to say the filtered part of[/color]
        Worksheets("" & myarr(rws) & "").Range("A" & ld & "").PasteSpecial Paste:=xlPasteValuesAndNumberFormats [color=lightgreen]'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=lightgreen]'Just tidy up a bit[/color]
        [color=blue]Next[/color] rws
    [color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
 
 
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 -  turn off the AutoFilters[/color]
rngTitle.Copy [color=lightgreen]'Copy Headings, and then in next line paste at end of Current Data, by pasting at the range ( call) that is at the intersect from the first heading colin and the next empty row in data sheet[/color]
Application.Intersect(wks1.Columns(sc), wks1.Rows("" & lr + 1 & "")).PasteSpecial Paste:=xlPasteAllUsingSourceTheme [color=lightgreen]'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]
 
TheEnd: [color=lightgreen]'Come Here for unexpected errors and do anything that should be done before ending program[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 -  turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen flicker after Copy Paste (clear the Clipboard.)[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'parse_data_AlanJuli2015[/color]
 
 
[color=lightgreen]'[/color]
'
 
 
 
[color=blue]Sub[/color] parse_data_AlanJuli2015HeadingCopyWithData()
 
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
 
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("Data") [color=lightgreen]'CHANGE THE SHEET NAME AS PER YOUR NEED - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet ( For first sheet : Set wks1 = ThisWorkbook.Worksheets(1) )[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'  turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping  '( 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=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'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=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet. Used for tempory Unique Range. Good idea to set to last column as this will not upset the determination of last column based on a Range.End(xltoleft) Property[/color]
[color=lightgreen]'--------------------------------------[/color]
 
[color=lightgreen]'Referrencing Ranges: Determine Columns, Ranges, Headings Required[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 4 [color=lightgreen]'CHANGE THE LOOK UP COLUMN NUMBER AS PER YOUR NEED 'Column where search criteria for filtering is.[/color]
[color=blue]Dim[/color] rngTitle [color=blue]As[/color] Range: [color=blue]Set[/color] rngTitle = wks1.Range("A1:F1") [color=lightgreen]'CHANGE THE TITLE ROW AS PER YOUR NEED[/color]
[color=blue]Dim[/color] sr [color=blue]As[/color] Long: [color=blue]Let[/color] sr = rngTitle.Row [color=lightgreen]'Initially sr is Upper Heading row[/color]
[color=blue]Dim[/color] sc [color=blue]As[/color] Long: [color=blue]Let[/color] sc = rngTitle.Column
Dim clmsOut [color=blue]As[/color] Range: [color=blue]Set[/color] clmsOut = Application.Union(wks1.Columns(2), wks1.Columns(1)) [color=lightgreen]'CHANGE TO COLUMNS YOU WANT COPIED[/color]
[color=lightgreen]'[color=blue]Dim[/color] rngTitleOut As Range: Set rngTitleOut = Application.Intersect(rngTitle, clmsOut) 'Creat new range by slices of Initial Full Title range[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(sr, lshtc).End(xlToLeft).Column [color=lightgreen]'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=blue]Dim[/color] Dataclm1 [color=blue]As[/color] Range: [color=blue]Set[/color] Dataclm1 = Intersect(wks1.Columns(sc), wks1.Rows("" & sr & ":" & lr & ""))
[color=blue]Dim[/color] Heading [color=blue]As[/color] String: [color=blue]Let[/color] Heading = Application.Intersect(rngTitle, wks1.Columns(vLkUpc)).Value [color=lightgreen]'This is the heading in the Look Up Column, coming from the Value in the intersect of the Look Up Column and the Title Range Row[/color]
 
Dim nr [color=blue]As[/color] Long: [color=blue]Let[/color] nr = wks1.Cells.Find(What:="" & Heading & "", After:=wks1.Cells(lr, vLkUpc), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 [color=lightgreen]'Detertmine start of New Data. Start at cell in arbritrary column, then go backwards and when heading found, get row +1 for start of new data[/color]
[color=lightgreen]'End of determining Required referrence ranges[/color]
   
[color=lightgreen]'        'Optional Start Bit to  Delete Sheets / Tabs------------[/color]
[color=lightgreen]'        Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=lightgreen]'        [color=blue]Dim[/color] ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=lightgreen]'        For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=lightgreen]'            If ws.Name <> "ASheetToKeep" And ws.Name <> "Data" And ws.Name <> wks1.Name And ws.Name <> "AR Report" And ws.Name <> "101206" Then 'Name property here returns name without .xlsm bit on end[/color]
[color=lightgreen]'            ws.Delete[/color]
[color=lightgreen]'            Else 'Presumably then the worksheet name is That of the first sheet so[/color]
[color=lightgreen]'            ' do nothing (Don't delete it!)[/color]
[color=lightgreen]'            End If[/color]
[color=lightgreen]'        Next ws[/color]
[color=lightgreen]'        Application.DisplayAlerts = True 'Turn it back on[/color]
[color=lightgreen]'        'End Bit to delete any Sheets / Tabs------------[/color]
   
    [color=lightgreen]'make an Array for Unique Search values, based only on new data, using a Tempory column[/color]
    [color=blue]Let[/color] wks1.Cells(1, lshtc) = Heading [color=lightgreen]'The last Column inn the sheet is used. (This has an advantage of not  interfering with our Method for getting lc). We give the array, that is to say the tempory column, a heading. Chosing the heading of the lookUpColumn is a neat trick : myarr will only ( uniquely ) stor it once at the top, and this will be neglected in the looping for sheet namnes[/color]
        [color=blue]For[/color] rws = nr [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows  from just after heading in First sheet[/color]
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'Necersary to ensure the looping goes on if the match row cannot be determined if it is not there yet[/color]
            [color=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = -1234 [color=blue]Then[/color] [color=lightgreen]'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 row. If it is there ( but not at a row of -1234 ! - a valid long number, but position that will never be found, )  we go to else.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=lightgreen]'.....we come here if match errored, so it was not to be found, so we put it there ![/color]
            [color=blue]Else[/color] [color=lightgreen]'Else do nothing - we had a match position. Redundant Code[/color]
            [color=blue]End[/color] [color=blue]If[/color]
        [color=blue]Next[/color] rws
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] 0 [color=lightgreen]'Disable the above Error handler now that we are finished using it[/color]
        [color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'Enable the default error handler for unpredictable errors[/color]
    Dim myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this [color=blue]Dim[/color]ensioning 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).Value)  [color=lightgreen]'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 (xlTextValues) would be 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=lightgreen]'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=lightgreen]'End of making an Array----------------------------------------[/color]
 
   
    [color=lightgreen]'Make a New worksheet, if necerssary with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
     Dim ld [color=blue]As[/color] [color=blue]Long[/color], rngCopy [color=blue]As[/color] Range [color=lightgreen]'Variable for last data entry in sheet, modified range to be copied from first sheet based on COLUMNS wanted[/color]
        [color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'For each unique value in the Array'From 2 removes the heading[/color]
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=lightgreen]'This blends out everything except  where rows meet our search citeria[/color]
            [color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'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=lightgreen]'Make it as that after the last sheet[/color]
            Worksheets("" & myarr(rws) & "").Range("A2").Value = "-" [color=lightgreen]'bogdge to offset start[/color]
            [color=blue]Else[/color]
            Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=blue]End[/color] [color=blue]If[/color]
   
        [color=lightgreen]'.......->>---...Copy Entire rows or columns required of range that is visible (Not blended out) to the current sheet in loop (Note: by default ommiting .SpecialCells(xlCellTypeVisible) also works![/color]
        [color=blue]Let[/color] ld = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row + 1  [color=lightgreen]'The Range Object last Cell in the sheet in column 1 has the property .End(with argument "looking Up" ) applied to return a new range ( cell) which is that of the last entry. To this cell the Property .Row is applied to give the row of that cell. +1 to get next row ( start of new data )[/color]
        [color=blue]Set[/color] rngCopy = Intersect(wks1.Rows("" & nr - 1 & ":" & lr & ""), clmsOut) [color=lightgreen]'Returns Range object based on intersection of rows and columns needed: Rows are those of new data , columns are USER selected. - 1 will return the headings when visible, which only will include the initial Top Headings which are allways visible.[/color]
        [color=lightgreen]'Dataclm1.SpecialCells(xlCellTypeVisible).Range("A" & nr & ":C" & lr & "").Copy 'This will modify copied range to only the first three columns. It is only necerssary to have first column in initial range, but you can also access as many more columns as you like. Only the new data is copied by virtue of the use of nr[/color]
        rngCopy.SpecialCells(xlCellTypeVisible).Copy [color=lightgreen]'This will copy the visible part, that is to say the filtered part of[/color]
        Worksheets("" & myarr(rws) & "").Range("A" & ld & "").PasteSpecial Paste:=xlPasteValuesAndNumberFormats [color=lightgreen]'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]
        Worksheets("" & myarr(rws) & "").Columns.AutoFit [color=lightgreen]'Just tidy up a bit[/color]
        [color=blue]Next[/color] rws
    [color=lightgreen]'End making (if necerssary) new sheet and copying filtered rows to it[/color]
 
 
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 -  turn off the AutoFilters[/color]
rngTitle.Copy [color=lightgreen]'Copy Headings, and then in next line paste at end of Current Data, by pasting at the range ( call) that is at the intersect from the first heading colin and the next empty row in data sheet[/color]
Application.Intersect(wks1.Columns(sc), wks1.Rows("" & lr + 1 & "")).PasteSpecial Paste:=xlPasteAllUsingSourceTheme [color=lightgreen]'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]
 
TheEnd: [color=lightgreen]'Come Here for unexpected errors and do anything that should be done before ending program[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1 -  turn off the AutoFilters[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen flicker after Copy Paste (clear the Clipboard.)[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'parse_data_AlanJuli2015HeadingCopyWithData[/color]
[color=lightgreen]'.........[/color]
'Einfügen    Insert  01.02.2015 00:02    .Paste
[color=lightgreen]'Formeln Formula 42036.00197 .PasteSpecial   Paste:=xlPasteFormulas[/color]
[color=lightgreen]'Werte   Value   42036.00197 .PasteSpecial   Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles   Everything  01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteAll[/color]
[color=lightgreen]'Formate Format      .PasteSpecial   Paste:=xlPasteFormats[/color]
[color=lightgreen]'Formate,     dann              Werte    Format,    followed by                        value 01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteFormats               .PasteSpecial   Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles mit Quelldesign   Everything with source design   01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteAllUsingSourceTheme[/color]
[color=lightgreen]'Alles außer Rahmen  Everything except Borders   01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteAllExceptBorders[/color]
[color=lightgreen]'Formeln und Zahlenwerte Formulas and number Format  01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteFormulasAndNumberFormats[/color]
[color=lightgreen]'Werte und Zahlenwerte   Value and Number Format 01.02.2015 00:02    .PasteSpecial   Paste:=xlPasteValuesAndNumberFormats[/color]
[color=lightgreen]'..........   seperate line needed for  .PasteSpecial   Paste:=xlPasteColumnWidths[/color]
 
 
 
 
 
[color=blue]Function[/color] UnionRanges(rOne [color=blue]As[/color] Excel.Range, rTwo [color=blue]As[/color] Excel.Range) [color=blue]As[/color] Excel.Range
    [color=blue]If[/color] rOne [color=blue]Is[/color] [color=blue]Nothing[/color] [color=blue]Then[/color]
        [color=blue]Set[/color] UnionRanges = rTwo
    [color=blue]Else[/color]
        [color=blue]Set[/color] UnionRanges = Application.Union(rOne, rTwo)
    [color=blue]End[/color] [color=blue]If[/color]
End [color=blue]Function[/color]





File ( “Passing_Wind.xlsm” XL 2007 )
https://app.box.com/s/aywkm9147s3jqtzrtixhtq003y6h0mdk

Thanks for watching and goodbye
Alan Elson
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
106
Scifo
S
S
  • Solved
VBA Parse Data. (do not want title to copy over Every time)
Replies
2
Views
467
Scifo
S
S
  • Question
VBA code_How to keep in Excel header row included when splitting worksheet to separate worksheets
Replies
1
Views
661
rlv01
R
S
  • Solved
Parse Data - Paste Range to new sheets as values only.
Replies
9
Views
565
Scifo
S
M
  • Question
Need to keep data only for one cell value.
Replies
0
Views
442
MDMitch
M

Forum statistics

Threads
1,214,402
Messages
6,119,301
Members
448,885
Latest member
LokiSonic

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