Splitting data from excel worksheet into multiple workbooks

Question

I\'m looking to split my data into multiple workbooks that will carry the name of my \"unique value\". Need to perform this several times per month, so am looking for an aut

Answer 1

Sub t()
On Error Resume Next
Application.DisplayAlerts = False

Dim new_book As Workbook
Dim newsheet As Worksheet

With ThisWorkbook.Sheets("Hierarchy")  'Replace the sheet name with the raw data sheet name

    Set newsheet = ThisWorkbook.Sheets("cal")

        If newsheet Is Nothing Then
                Worksheets.Add.Name = "cal"
            Else
                ThisWorkbook.Sheets("cal").Delete
                Worksheets.Add.Name = "cal"
        End If

            .Columns("a").Copy

                With ThisWorkbook.Sheets("cal")
                    .Range("a1").PasteSpecial (xlPasteAll)
                    .Columns("a").RemoveDuplicates Columns:=1, Header:=xlYes
                End With

                        For Each cell In ThisWorkbook.Sheets("cal").Columns("a").Cells
                            i = i + 1
                                If i <> 1 And cell.Value <> "" Then
                                    .AutoFilterMode = False
                                    .Rows(1).AutoFilter field:=3, Criteria1:=cell.Value
                                    Set new_book = Workbooks.Add
                                    .UsedRange.Copy
                                    new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll)
                                    new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx"
                                    new_book.Sheets(1).UsedRange.Columns.AutoFit
                                    new_book.Save
                                    new_book.Close
                                End If
                        Next cell

                            ThisWorkbook.Sheets("cal").Delete
End With

End Sub