Split selected column into sheets Macro

[doriannjeshi]

Hi,
Is it possible to split the content of a selected column into seperate new sheets named after them. But the column is not fixed , but the selected one. In this case B

Book2
	A	B	C	D	E	F
1	A	B	C	D	E	F
2	a-bori	3			-3	1
3	1	1	1	1	1	1
4	1	3	1	1	1	1
5	1	1	1	1	1	1
6	1	3	1		1	1
7	a-bori	1	1	1	1
8	1	3	1	1	1	1
9	1	1	1	-6		1
10	1	3	1	1
11	a-bori	1	1	1	1	1
12	1	2		1	1	1
13	1	2	1	1	1	1
14	1	2	1		1	1
sheet1

 

[DanteAmor]

In your example, if you select column D, then you must have 2 sheets: "1" and "-6" ?

Should the macro always create the sheets? That is, if sheet "1" already exists, should it delete the content of sheet "1" and put in the new data?

 

[doriannjeshi]

In your example, if you select column D, then you must have 2 sheets: "1" and "-6" ?

Should the macro always create the sheets? That is, if sheet "1" already exists, should it delete the content of sheet "1" and put in the new data?

Hi Dante,
Yes the the macro should create the sheets, if possible to delete the content of the sheet if exists first and put the new data would be a nice option

 

[DanteAmor]

Try this:

Sub split_column()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim c As Range
  Dim col As Long, lr As Long, i As Long
  Dim dic As Object
  Dim ky As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  col = ActiveCell.Column
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Cells(Rows.Count, col).End(3).Row
  
  For Each c In sh1.Range(sh1.Cells(2, col), sh1.Cells(Rows.Count, col).End(3))
    If c.Value <> "" Then dic(c.Value) = Empty
  Next
  
  For Each ky In dic.Keys
    On Error Resume Next: Sheets(Trim(Str(ky))).Delete: On Error GoTo 0
    sh1.Range("A1").AutoFilter col, ky
    Sheets.Add(, Sheets(Sheets.Count)).Name = ky
    sh1.AutoFilter.Range.EntireRow.Copy Range("A1")
  Next

  sh1.Select
  sh1.AutoFilterMode = False
  Application.ScreenUpdating = False
End Sub

 

[doriannjeshi]

I get this:

 

[DanteAmor]

Try this:

Sub split_column()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim c As Range
  Dim col As Long, lr As Long, i As Long
  Dim dic As Object
  Dim ky As Variant
  Dim sName As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  col = ActiveCell.Column
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Cells(Rows.Count, col).End(3).Row
  
  For Each c In sh1.Range(sh1.Cells(2, col), sh1.Cells(Rows.Count, col).End(3))
    If c.Value <> "" Then dic(c.Value) = Empty
  Next
  
  For Each ky In dic.Keys
    sName = Trim(Str(ky))
    On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
    sh1.Range("A1").AutoFilter col, ky
    Sheets.Add(, Sheets(Sheets.Count)).Name = ky
    sh1.AutoFilter.Range.EntireRow.Copy Range("A1")
  Next

  sh1.Select
  sh1.AutoFilterMode = False
  Application.ScreenUpdating = False
End Sub

 

[doriannjeshi]

I get the same error

 

[DanteAmor]

I think I didn't consider that sheets, in addition to being called numbers, can also be called letters.

Try this:

Sub split_column()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim c As Range
  Dim col As Long, lr As Long, i As Long
  Dim dic As Object
  Dim ky As Variant
  Dim sName As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  col = ActiveCell.Column
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Cells(Rows.Count, col).End(3).Row
  
  For Each c In sh1.Range(sh1.Cells(2, col), sh1.Cells(Rows.Count, col).End(3))
    If c.Value <> "" Then dic(c.Text) = Empty
  Next
  
  For Each ky In dic.Keys
    sName = ky
    On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
    sh1.Range("A1").AutoFilter col, ky
    Sheets.Add(, Sheets(Sheets.Count)).Name = ky
    sh1.AutoFilter.Range.EntireRow.Copy Range("A1")
  Next

  sh1.Select
  sh1.AutoFilterMode = False
  Application.ScreenUpdating = False
End Sub

 

[doriannjeshi]

Excellent , Thank you