Copy column to new sheet and rename sheet with column header

[RoryF]

Hi,
Apologies in advance if this has been asked before i couldn't find the solution in was looking for.

I have a sheet with 100's of columns, each column has different amount of rows and a header. What i am trying to achieve is have each column copied to it's own sheet and the name of the sheet named with the column header, i've tried a few macro's but none meet my need.

Can anyone help with a macro that would help me achieve this?

Thanks

 

[RoryA]

Welcome to the forum.

Do you want new sheets added in the same workbook, or to a new workbook?

 

[RoryF]

Thanks for the reply.

I would like them on the same workbook if possible.

 

[RoryA]

Try this:

Sub copyToSheets()
   Dim sourceSheet As Worksheet
   Set sourceSheet = ActiveSheet
   
   Application.ScreenUpdating = False
   
   With sourceSheet.UsedRange
   
      Dim colNum As Long
      For colNum = 1 To .Columns.Count
         copyToNewSheet .Columns(colNum)
      Next colNum
      
   End With
   
   sourceSheet.Activate
   
   Application.ScreenUpdating = True
End Sub
Sub copyToNewSheet(sourceRange As Range)

   With sourceRange.Worksheet
   
      Dim lastRow As Long
      lastRow = .Cells(.Rows.Count, sourceRange.Column).End(xlUp).Row
      
      With .Parent.Worksheets
         Dim newSheet As Worksheet
         Set newSheet = .Add(after:=.Item(.Count))
      End With
      
   End With
   newSheet.Name = sourceRange.Cells(1).Value
      
   sourceRange.Resize(lastRow - sourceRange.Row + 1).Copy newSheet.Range("A1")
      
End Sub

 

[RoryF]

Cheers, that worked a treat.

Thanks