![]()
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
Bookmarks