Page 4 of 12 FirstFirst ... 23456 ... LastLast
Results 31 to 40 of 111

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

  1. #31
    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 Jasbels View Post
    These VBA codes seem just what I need but the name of the data I want to split contains "/". My question is, therefore, is it possible to split data with "/" in the name? or would I need to rename the cells first. If so could someone help me with what the code would be and where it would appear within the code used to split the data into multiple worksheets.

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

  2. #32
    New Member
    Join Date
    Mar 2014
    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, I am just reviving this old thread regarding Splitting data into multiple sheets. I got the below code from this forum, it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. I would appreciate any help in this. Sub Staffing_Budget_parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1 'set column number
    Set ws = Sheets("FTE Summary") 'set sheet name
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1" ' set title row
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub

  3. #33
    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 karan1916 View Post
    Hello, I am just reviving this old thread regarding Splitting data into multiple sheets. I got the below code from this forum, it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. I would appreciate any help in this. ...........


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

    Alan

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

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

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

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

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

    Quote Originally Posted by karan1916 View Post
    ……. ……..it does exactly everything I need it to do except one. It copies and paste data as values. I want it to just copy and paste data, so the formulas in the original sheet are also copied. ……………………….
    . 2) I see no formulas in the file you sent so I do not quite understand. The data needs to be representative which means if you have and want formulas to be copied then it should have some typical formulas in it.

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

    Quote Originally Posted by karan1916 View Post
    …….. I have now a further request. Instead of saving them to the same workbook by adding new tabs, I would need the data to be copied in a new excel workbook. The new workbook can have the same name based on the unique value. if there are 50 unique values then I should have 50 workbooks in the folder. ………
    .3 ) whether the code makes a new sheet or new workbook is hardly any difference to the coding, so no problem at all there. Wot is a problem for me is it is still not obvious exactly how a new sheet or sheet in a new file should Look like. I guess your unique values are those in column D. But Please supply at least one sheet in the same or a new workbook showing exactly how your final data should look like based on your sample data.

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

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

    Alan

  6. #36
    New Member
    Join Date
    Mar 2014
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

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

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

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

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

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

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

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

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

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


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


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

  8. #38
    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 karan1916 View Post
    .............. So the main thing is to tweak the existing macro to retain the formulas in the original data. .....


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

    Codes bodging Karan’s Sub Staffing_Budget_parse_data():



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

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

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

    Code:
    '
    '
    Sub KaranAdvFiltBodgeCopy2()
    Application.ScreenUpdating = False 'Not necerssary but speeds things up a bit, by turning screen updating off.
    'On Error GoTo TheEnd 'If anything goes wrong go to the End instead of crashing.
    Dim wks1 As Worksheet: Set wks1 = ThisWorkbook.Worksheets(1) 'Give abbreviation for first sheet in this all Properties and methoods of Object Worksheet
     
    '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 <> wks1.Name 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
    Application.DisplayAlerts = True 'Turn it back on
    'End Bit to delete any Sheets / Tabs------------
     
    'Add new Worksheets---
        'Make Tempory Sheet
        Dim Record As String 'Record name, not kept constant, used / updated in looping
        Dim LastRecordRow As Long ' 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 LastRecordColumn As Long
       
        'Let Worksheets.Add(After:=Worksheets(1)).Name = "Unique1" 'Add a Worksheet after the first, named Unique1 for now
        Let Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Unique1" 'Add a Worksheet after the last, named Unique1 for now
        Let LastRecordRow = wks1.Range("A" & Rows.Count).End(xlUp).Row 'Go to last row in  Column 1, come back up to last entry and get the row there..allows for differnt versions of Excel with different number of rows.
        '          Let LastRecordRow = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Alternative method: You start at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers) - Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell
        wks1.Range("A1:A" & LastRecordRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=True 'Copies entire A Column to first column in sheet2 (Tempory made "Unique1" sheet), The important bit is Unique:=True - that only copies unique Nuimbers
        '---------------------
     
    Dim LastUnqRow As Long, UqeRow As Long 'Rows in Tempory Unique sheet. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)
    Let LastUnqRow = Worksheets("Unique1").Cells(Rows.Count, 1).End(xlUp).Row 'get last Row from Column 1..
    '                     Let LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Get last Unique Row for use in next loop. method: You starta at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell
     '### get Row Indices for Stupid Bodge
      Dim BodgeStartRow As Long: Let BodgeStartRow = 2 'Start of first range for Re - Copy. Set tohere to just below heading
      Dim RangeBodgeRows As Long 'Variable for Range Row in New record Shhet
      For UqeRow = 2 To LastUnqRow Step 1 '
        'Make new sheet------------
        If Sheets("Unique1").Cells(UqeRow, 1).Text <> "" Then 'Assuming a Record is there
        Let Record = Sheets("Unique1").Cells(UqeRow, 1).Text 'Put name in Record variable
        'Let Worksheets.Add(After:=Worksheets(1)).Name = Record 'Add new worksheet with Record name
        Let Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Record
           'Copying data to new sheet----
            wks1.UsedRange.AutoFilter Field:=1, Criteria1:=Record 'Filter out everything except with that with the appropriate Record (makes visible based on the criteria only the stuff you want)....
            wks1.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(Record).Range("A1") ', then combine it with SpecialCells to just copy that wot you see, (and then send it to the relavent new sheet , name n).. ( Idid notice that it works the same without the .SpecialCells(xlCellTypeVisible) bit, - but that mayjust be Excel “guessing wot you want” as it does, that is to say it copies by default wot is visible?- not too sure on that one yet.)
            wks1.AutoFilterMode = False 'This has been automatically been set to true, so we only see the visible fltered. We could leave this turned on until the end, but for debugging it helps to turn it back onn here, that is to say make entire first sheet visible.
           '-------------------------------------------------
     
         
          With Worksheets(Record).UsedRange 'Bit of simple Format Tidying up
            .WrapText = False
            .Columns.AutoFit
          End With
       
        Else
        'Do nothing if no Record given
        End If
        '-----------------------------
      '### Copy Bodge
      Let LastRecordColumn = Worksheets(Record).Cells(2, Columns.Count).End(xlToLeft).Column 'Start in first Column second row, go to the last column in that row, come back to last entry and get the column number of it. Allows for differet Column numbers but for karan Column H would 'ave done!!
      Let RangeBodgeRows = Worksheets(Record).Range("A" & Rows.Count).End(xlUp).Row 'Needed range row length (+1) for copy bodge
      ' Alternative for above for getting size of range to be copied Let RangeBodgeRows = Worksheets(Record).Range("A1").CurrentRegion.Rows.Count: Let LastRecordColumn = Worksheets(Record).Range("A1").CurrentRegion.Columns.Count
     
        wks1.Range("A" & BodgeStartRow & ":A" & BodgeStartRow + RangeBodgeRows - 2).EntireRow.Copy Destination:=Sheets(Record).Range("A2") 'Copy destination method, but now using a specified Range
     
      Let BodgeStartRow = BodgeStartRow + RangeBodgeRows - 1
      Next UqeRow 'Go back and make another new sheet
        '                    ws.Range("A1:H1").Copy Destination:=Sheets(myarr(i) & "").Range("A1:H1")'Headers: - This is done alreadyas a by product from the Advanced filter copy
    'wks1.AutoFilterMode = False'It is more useual to do this here,
     
    Application.DisplayAlerts = False 'Prevent being asked if you really want to delete Temporary Unique sheet
    Sheets("Unique1").Delete ' delete the filtered Record name sheet as you do not need it any more
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True 'Turn screen "back on" or screen is "dead"
    Exit Sub 'We stop code here assuming it worked (or at least did not crash!)
    TheEnd:
    Application.ScreenUpdating = True 'Important to do this here so if anything goes wron then the screen updating is turned back on, ohterwisee the screen is dead
    MsgBox (Err.Description) 'Print out error message in Message Box
    End Sub 'KaranAdvFiltBodgeCopy2()
    . I also tidied everything up a little bit and changed the sheet order to the same as yours.



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

    . Alan.

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

  9. #39
    New Member
    Join Date
    Mar 2014
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

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

  10. #40
    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

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

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


    Code:
    Sub Staffing_Budget_parse_data_AlanJan2015()
     
    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(1) 'set sheet name - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet
     
            '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 <> wks1.Name 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 = 1 '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). hee 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 not there then.....
                wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) '.....Put  it there
                Else 'Else do nothing
                End If
            Next rws
        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, xlTextValues).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 are there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.
        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 = 2 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
                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 row 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
            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
     
    wks1.AutoFilterMode = False 're - Blend in everything in sheet 1
    wks1.Activate 'Activate that sheet 1 just to see it
     
    TheEnd:
    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.
     
    End Sub 'Staffing_Budget_parse_data_AlanJan2015()

    ….then simplified without comments etc.


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



    ………………………

    Alan….

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
  •