Page 10 of 12 FirstFirst ... 89101112 LastLast
Results 91 to 100 of 111

Thread: VBA: Split data into multiple worksheets based on column

  1. #91
    Banned user
    Join Date
    May 2014
    Location
    Germany
    Posts
    1,336
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    Quote Originally Posted by Ken_W View Post
    .......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
    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-q...-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-q...ll-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 by DocAElstein; May 7th, 2015 at 04:18 PM.

  2. #92
    New Member
    Join Date
    May 2015
    Location
    Pensacola, FL
    Posts
    17
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    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!

  3. #93
    Banned user
    Join Date
    May 2014
    Location
    Germany
    Posts
    1,336
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    Quote Originally Posted by Ken_W View Post
    ..
    Thank you for the quick response. ..
    ..!
    Yous welcome, thanks for the Feedback.

    Quote Originally Posted by Ken_W View Post
    .. 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…!
    .. 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..

    Quote Originally Posted by Ken_W View Post
    ……
    I created a new file, copy/pasted my data into it and it opens fairly quickly now so don’t know about that either. …
    . 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.

  4. #94
    New Member
    Join Date
    Jul 2015
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Talking Re: VBA: Split data into multiple worksheets based on column

    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

  5. #95
    New Member
    Join Date
    Jul 2015
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

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

  6. #96
    Banned user
    Join Date
    May 2014
    Location
    Germany
    Posts
    1,336
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    Quote Originally Posted by emperorlord View Post
    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
    ........

    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:
            '.......->>---...Copy Entire rows or columns of range that is visible (Not blended out) to the current sheet in loop
            wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy '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
            wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy ' first by .SpecialCells(xlCellTypeVisible) Method and then by EntireRow Property
            wks1.Range("G" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy ' Important is only that lr is used, or rather entire virtical range
            wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 1 & ":H" & lr & "").Copy 'Alternative way of selecting Entire Range
            wks1.Range("A" & 1 & ":H" & lr & "").SpecialCells(xlCellTypeVisible).Copy 'Will also work for Entire Row !!
            wks1.Range("A" & 1 & ":B" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 1 & ":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
            Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=xlPasteFormulas '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
            Sheets("" & myarr(rws) & "").Columns.AutoFit 'Just tidy up a bit
            Next rws
        'End making (if necerssary) new sheet and copying filtered rows to it
    .................................
    . 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 by DocAElstein; Jul 22nd, 2015 at 09:13 AM.

  7. #97
    New Member
    Join Date
    Jul 2015
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    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?resi...nt=file%2cxlsm
    Last edited by RoryA; Jul 23rd, 2015 at 09:24 AM.

  8. #98
    Banned user
    Join Date
    May 2014
    Location
    Germany
    Posts
    1,336
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    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
    Data
    ........

    . 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
    10612422


    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
    10611201


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

    . With regards to your new requirement, from Post #97 –
    Quote Originally Posted by emperorlord View Post
    ……
    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…..
    . 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
    Data

    . 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
    Data

    . 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:
    Option Explicit
    Sub emperorlord_parse_data_AlanJuli2015_1()
     
    Application.ScreenUpdating = False 'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging
    On Error GoTo TheEnd 'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging
    Dim wks1 As Worksheet: Set wks1 = ThisWorkbook.Worksheets("Data") '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) )
    wks1.AutoFilterMode = False '  turn off the AutoFilters
            'Start Bit to  Delete Sheets / Tabs------------
            Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook
            Dim ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it!
            For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")
                If ws.Name <> "ASheetToKeep" 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
                ws.Delete
                Else 'Presumably then the worksheet name is That of the first sheet so
                ' do nothing (Don't delete it!)
                End If
            Next ws
            Application.DisplayAlerts = True 'Turn it back on
            'End Bit to delete any Sheets / Tabs------------
     
    'Some variables used in various places
    Dim vLkUpc As Long: Let vLkUpc = 4 '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)
    Dim rws As Long 'Bound variable Row count used in looping
    Dim lr As Long: Let lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '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
    Dim lshtc As Long: Let lshtc = wks1.Columns.Count 'Number of Columns in sheet
    Dim lc As Long: Let lc = wks1.Cells(1, lshtc).End(xlToLeft).Column '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
    '--------------------------------------
     
        'make an Array for Unique Search values, using a Tempory column
        Let wks1.Cells(1, lshtc) = "Unique" '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
            For rws = 2 To lr Step 1 'Going down all rows  from just after heading in First sheet
            On Error Resume Next 'Necersary to ensure the looping goes on if the match cannot be determined, as below we have a look Up Array with empty cells
                If wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 Then '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.....
                wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) '.....Put  it there
                Else 'Else do nothing - we already had a match
                End If
            Next rws
            On Error GoTo 0 'Disable the above Error handler
            On Error GoTo TheEnd 'Enable the default error handler for unpredictable errors
        Dim myarr() As Variant '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
        myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlNumbers).Value) '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.
        wks1.Columns(lshtc).Delete '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
        'End of making an Array----------------------------------------
     
        'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-
            For rws = 1 To UBound(myarr) 'For each unique value in the Array
            wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter Field:=vLkUpc, Criteria1:="" & myarr(rws) & "" 'This blends out everything except  where rows meet our search citeria
                If Not Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then '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
                Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" 'Make it as that after the last sheet
                wks1.Range("A1").EntireRow.Copy
                Worksheets("" & myarr(rws) & "").Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                Else
                Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) 'Otherwise If the sheet is there it could be anywhere so we put it after last sheet
                End If
       
            '.......->>---...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!
           
            wks1.Range("A" & 1 & ":B" & lr & "").SpecialCells(xlCellTypeVisible).Range("A" & 2 & ":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
            Worksheets("" & myarr(rws) & "").Range("A4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats '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
            Sheets("" & myarr(rws) & "").Columns.AutoFit 'Just tidy up a bit
            Next rws
        'End making (if necerssary) new sheet and copying filtered rows to it
     
     
    wks1.Activate 'Activate that sheet 1 just to see it
     
    TheEnd: 'Come Here for unexpected errors and do anything that should be done before ending program
    Application.ScreenUpdating = True 'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.
    wks1.AutoFilterMode = False 're - Blend in everything in sheet 1 -  turn off the AutoFilters
    Application.CutCopyMode = False 'Stops screen flicker after Copy Paste (clear the Clipboard.)
    End Sub 'emperorlord_parse_data_AlanJuli2015_1()Sub emperorlord_parse_data_AlanJuli2015_1()
     
     
     
    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
    Last edited by DocAElstein; Jul 23rd, 2015 at 09:03 AM.

  9. #99
    New Member
    Join Date
    Jul 2015
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

    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

  10. #100
    Banned user
    Join Date
    May 2014
    Location
    Germany
    Posts
    1,336
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA: Split data into multiple worksheets based on column

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




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

    Thanks for watching and goodbye
    Alan Elson

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •