Results 1 to 10 of 10

How to split worksheet into multiple worksheets based on column content

Threaded View

  1. #3
    Registered User
    Join Date
    06-03-2014
    Posts
    6

    Re: Code does not work

    Option Explicit
    
    Sub ParseSiteData()
    'JBeaucaire  (11/11/2009)
    'Based on column A, data is filtered to individual sheets
    'Creates sheets and sorts alphabetically in workbook
    Dim LR As Long, i As Long, MyArr
    Dim MyCount As Long, ws As Worksheet
    Application.ScreenUpdating = False
    
    Set ws = Sheets("Data")      'edit to sheet with master data
    ws.Activate
    
    Rows(1).Insert xlShiftDown
    Range("A1") = "Key"
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("CC1"), Unique:=True
    Columns("CC:CC").Sort Key1:=Range("CC2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    MyArr = Application.WorksheetFunction.Transpose(Range("CC2:CC" & Rows.Count).SpecialCells(xlCellTypeConstants))
    
    Range("CC:CC").Clear
    Range("A1").AutoFilter
    
    For i = 1 To UBound(MyArr)
        ws.Range("A1").AutoFilter Field:=1, Criteria1:=MyArr(i)
        LR = ws.Range("A" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
            Else
                Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
                Sheets(MyArr(i)).Cells.Clear
            End If
            ws.Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                Sheets(MyArr(i)).Range("A1")
            ws.Range("A1").AutoFilter Field:=1
            MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
            Sheets(MyArr(i)).Columns.AutoFit
        End If
    Next i
    
    ws.Activate
    ws.AutoFilterMode = False
    LR = ws.Range("A" & Rows.Count).End(xlUp).Row - 1
    Rows(1).Delete xlShiftUp
    MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
    End Sub
    Last edited by Laurelmzitney; 06-03-2014 at 09:30 AM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Code locks cells when inserted in sheet module but returns error in standard module
    By yoda66 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 02-07-2014, 07:39 AM
  2. Replies: 1
    Last Post: 08-30-2011, 02:23 AM
  3. how to access Sheet module, normal module, Worbook module to type code
    By alibaba in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 10-31-2009, 07:51 AM
  4. Replies: 2
    Last Post: 03-27-2009, 11:48 AM
  5. Replies: 1
    Last Post: 04-10-2005, 07:07 PM

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1