Split workbook into separate worksheets and copy only certain columns to new worksheets

[Imtiaz]

Hi....I found this code on the forum to split workbook into separate worksheets which works perfectly but I only want to copy across certain columns to the new worksheets. I want columns I, M and W to copy across the new tabs. Can someone please assist. This

Sub columntosheets()


Const sname As String = "Master" 'change to whatever starting sheet
Const s As String = "M" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh


Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate


End Sub

 

[Fluff]

How about

Sub Imtiaz()
   Dim cl As Range
   Dim ws As Worksheet
   Dim Ky As Variant
   
   Application.ScreenUpdating = False
   Set ws = Sheets("Master")
   With CreateObject("scripting.dictionary")
      For Each cl In ws.Range("M2", ws.Range("M" & Rows.Count).End(xlUp))
         If Not .Exists(cl.Value) Then .Add cl.Value, Nothing
      Next cl
      For Each Ky In .Keys
         ws.Range("A1").AutoFilter 13, Ky
         If Not Evaluate("=ISREF('" & Ky & "'!A1)") Then
            Sheets.Add(, ws).Name = Ky
            Intersect(ws.AutoFilter.Range.EntireRow, ws.Range("I:I,M:M,W:W")).Copy Sheets(Ky).Range("A1")
            Sheets(Ky).Columns.AutoFit
         End If
      Next Ky
   End With
   ws.AutoFilterMode = False
   ws.Activate
End Sub

 

[Imtiaz]

Thanks so much for that code. It does split the worksheets and copy over the selected columns but I get a debug error - mismatch on

If Not Evaluate("=ISREF('" & Ky & "'!A1)") Then

Thanks

 

[Fluff]

Do you have any blank cells in col M?
Also what sort of values do you have in col M

 

[Imtiaz]

There are no blank cells and they are all text values the biggest is 11 characters. Some cells are all capitals some are lower case.

 

[Fluff]

When you get the error hover the mouse of Ky, and it should give you the value that Ky holds, what is it?

 

[Imtiaz]

Ky = ""

 

[Imtiaz]

Apologies there is a blank cell in M on the last line where the total is

 

[Imtiaz]

Apologies there is a blank cell in M on the last line where the total is

When I removed the last row with the total it works fine without the error. Is there a way to exclude the last total row?

Also once the code has run all the rows on the master sheet become hidden. Is it possible to leave the master sheet as it is to show all the rows.

Thanks.

 

[Fluff]

This will ignore the last row

Sub Imtiaz()
   Dim cl As Range
   Dim ws As Worksheet
   Dim Ky As Variant
   
   Application.ScreenUpdating = False
   Set ws = Sheets("Master")
   With CreateObject("scripting.dictionary")
      For Each cl In ws.Range("M2", ws.Range("M" & Rows.Count).End(xlUp)[COLOR=#ff0000].Offset(-1)[/COLOR])
         If Not .Exists(cl.Value) Then .Add cl.Value, Nothing
      Next cl
      For Each Ky In .Keys
         ws.Range("A1").AutoFilter 13, Ky
         If Not Evaluate("=ISREF('" & Ky & "'!A1)") Then
            Sheets.Add(, ws).Name = Ky
            Intersect(ws.AutoFilter.Range.EntireRow, ws.Range("I:I,M:M,W:W")).Copy Sheets(Ky).Range("A1")
            Sheets(Ky).Columns.AutoFit
         End If
      Next Ky
   End With
   [COLOR=#0000ff]ws.AutoFilterMode = False[/COLOR]
   ws.Activate
End Sub

The line in blue should also remove the filter leaving everything visible