VBA Split Table into Multiple Worksheets Keeping Header

[LALD]

Hi,

I am quite new to VBA but learning (slowly). I have a table in cells A20:CM520, the first 19 rows are instructions and a header which I wish to keep if possible. I would like to filter by column X and paste the visible cells (preserving their format) to a new worksheet for each name filtered in column X (using that name as the worksheet name). I have got this code so far but am struggling to get it up and running, apologies for my inexperience and thank you in advance for your help. I am using Excel 2010:

Sub SplitWorkbook()
Rows("19:19").Select
Range("AO19").Activate
ActiveSheet.Range("$A$19:$CN$572").AutoFilter Field:=24,
Cells.Select
Range("K1").Activate
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Workbooks.Add
Application.CutCopyMode = False
ActiveSheet.Paste
ActiveWindow.Close
ActiveSheet.Range("$A$19:$CN$572").AutoFilter Field:=24
Range("A1").Select
End Sub


Thank you so much in advance! If I can crack this it will save me such a huge amount of time.

Thanks,

Lald

 

[hippiehacker]

try

Sub LALD()
Set asheet = ActiveSheet
lastrow = asheet.Range("X" & Rows.Count).End(xlUp).Row
myarray = uniqueValues(asheet.Range("X20:X" & lastrow))

For i = LBound(myarray) To UBound(myarray)
 Sheets.Add.Name = myarray(i)
 asheet.Range("A19:CN" & lastrow).AutoFilter Field:=24, Criteria1:=myarray(i)
 asheet.Range("A19:CN" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
        Sheets(myarray(i)).Range("A1")
 asheet.Range("A19:CN" & lastrow).AutoFilter
Next i
End Sub

Private Function uniqueValues(InputRange As Range)
    Dim cell As Range
    Dim tempList As Variant: tempList = ""
    For Each cell In InputRange
        If cell.Value <> "" Then
            If InStr(1, tempList, cell.Value) = 0 Then
                If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
            End If
        End If
    Next cell
    uniqueValues = Split(tempList, "|")
End Function

 

[LALD]

Thank you so much for your suggestion. I just tried it and it is a fantastic start. Thank you. I just need to give it a bit of tweaking as it did not copy across the formulae or the information above the header (rows 1 to 18 or 19 if you include the header). If I can get the formulae to copy across that would be great. I will have a go at this and if I can't fix it I'll find a work around.

Thank you so much for your help. Really appreciate your time.

 

[hippiehacker]

Thank you so much for your suggestion. I just tried it and it is a fantastic start. Thank you. I just need to give it a bit of tweaking as it did not copy across the formulae or the information above the header (rows 1 to 18 or 19 if you include the header). If I can get the formulae to copy across that would be great. I will have a go at this and if I can't fix it I'll find a work around.

Thank you so much for your help. Really appreciate your time.

to copy the rows above row 19 as well change line

asheet.Range("A19:CN" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
        Sheets(myarray(i)).Range("A1")

with

asheet.Range("A1:CN" & lastrow).SpecialCells(xlCellTypeVisible).Copy _
        Sheets(myarray(i)).Range("A1")

 

[LALD]

Thank you that is perfect! I am now just working out a way of pasting formulas. Thank you so much for your help. Really appreciate this, it has saved me so much time!

 

[pawanhsharma]

I have a similar problem, usually I pulled data from SQL server and split it to different worksheets based on a perticular column. cCan we modify this code work dynamically as per user input for the table range and column to be filtered.

 

[Roxanne8912]

Is there a way to modify the code in post #2 to keep the original column width? Also, to keep embedded objects with the appropriate row/column after the split. Embedded objects do carry over to the new worksheet. However, ones from the previous row may carry over inappropriately, or the object show as a single small line which has to be resized.