generate sheet automatically on the basis of auto filter on specific column

T

tanmanoj

New member
Joined
Oct 6, 2013
Messages
5
Reaction score
0
Points
0
Dear Sir,

i attached a excel in which i have a to x column. i want to generate sheet automatically with the name of filter value on the basis of autofilter on column name sub-div or other column. can u provide me the vba code for this please.

thanks
manoj
 

Attachments

  • september13.xlsx
    462.6 KB · Views: 16
There's a macro in the attached workbook.
The macro is:
Code: 
Sub blah()
Dim Response As Range
On Error Resume Next
Set Response = Application.InputBox("Select any cell in the column you want filtered new sheets for", "Select a column", "$I$1", , , , , 8)
On Error GoTo here
If Not Response Is Nothing Then
  Application.ScreenUpdating = False
  Set OrigSht = Response.Parent
  With OrigSht
    Set Response = .Cells(1, Response.Column)
    Set RangeToFilter = Intersect(.UsedRange, Response.EntireColumn)
'Set RangeToFilterData = RangeToFilter.Offset(1).Resize(RangeToFilter.Rows.Count - 1)
    Set uniqueSht = Sheets.Add(After:=Sheets(Sheets.Count))
    RangeToFilter.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=uniqueSht.Range("A1"), Unique:=True
    Set UniqueRng = uniqueSht.UsedRange
    Set UniqueRng = UniqueRng.Offset(1).Resize(UniqueRng.Rows.Count - 1)
    For Each cll In UniqueRng
      RangeToFilter.AutoFilter Field:=1, Criteria1:=cll.Value
      Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
      OrigSht.UsedRange.Copy
      newsht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      OrigSht.UsedRange.Copy newsht.Range("A1")
'get new sheet name:
      newshtName = Application.Trim(Response.Value & " " & cll.Value)
'remove illegal sheet name characters:
      For i = 1 To 7
        newshtName = Replace(newshtName, Mid(":\/?*[]", i, 1), vbNullString)
      Next i
'name the sheet:
      newsht.Name = Right(newshtName, 31)
    Next cll
  End With
  RangeToFilter.AutoFilter
  Application.DisplayAlerts = False
  uniqueSht.Delete
  Application.DisplayAlerts = True
  MsgBox "Done"
End If
here:
Application.ScreenUpdating = True
End Sub
 

Attachments

  • ExcelGuru2893september13.xlsm
    485.1 KB · Views: 9
p45cal said:
There's a macro in the attached workbook.
The macro is:
Code: 
Sub blah()
Dim Response As Range
On Error Resume Next
Set Response = Application.InputBox("Select any cell in the column you want filtered new sheets for", "Select a column", "$I$1", , , , , 8)
On Error GoTo here
If Not Response Is Nothing Then
  Application.ScreenUpdating = False
  Set OrigSht = Response.Parent
  With OrigSht
    Set Response = .Cells(1, Response.Column)
    Set RangeToFilter = Intersect(.UsedRange, Response.EntireColumn)
'Set RangeToFilterData = RangeToFilter.Offset(1).Resize(RangeToFilter.Rows.Count - 1)
    Set uniqueSht = Sheets.Add(After:=Sheets(Sheets.Count))
    RangeToFilter.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=uniqueSht.Range("A1"), Unique:=True
    Set UniqueRng = uniqueSht.UsedRange
    Set UniqueRng = UniqueRng.Offset(1).Resize(UniqueRng.Rows.Count - 1)
    For Each cll In UniqueRng
      RangeToFilter.AutoFilter Field:=1, Criteria1:=cll.Value
      Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
      OrigSht.UsedRange.Copy
      newsht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      OrigSht.UsedRange.Copy newsht.Range("A1")
'get new sheet name:
      newshtName = Application.Trim(Response.Value & " " & cll.Value)
'remove illegal sheet name characters:
      For i = 1 To 7
        newshtName = Replace(newshtName, Mid(":\/?*[]", i, 1), vbNullString)
      Next i
'name the sheet:
      newsht.Name = Right(newshtName, 31)
    Next cll
  End With
  RangeToFilter.AutoFilter
  Application.DisplayAlerts = False
  uniqueSht.Delete
  Application.DisplayAlerts = True
  MsgBox "Done"
End If
here:
Application.ScreenUpdating = True
End Sub
Click to expand...


Thanks for your accurate reply its work fine but when i run on actual file(attach as attachment ) i found that two sheet are created with two sub div data and it generate one sheet which have all the sheet name actually good from where i get that which sheet not created which one is double. please correct me that where is the problem in my data. i want to put sample file with your vba code but it exceed the size of attachment so i cant. please put this code in the attachment file

thanks
manoj
 

Attachments

  • sample1.xlsx
    295.9 KB · Views: 11
You have data which includes many spaces like:
"N31~~~~~~~~~~~~~~~~~~"
(where a "~" represents a space) and like this (without spaces):
"N31"
My unique filtering treats them as different, Autofilter treats them the same.

You also have entries which are just 40 spaces which are also treated as blanks by the Autofilter.

Either remove the extra spaces from the data or use this adjusted macro below.
Code: 
Sub blah()
Dim Response As Range
On Error Resume Next
Set Response = Application.InputBox("Select any cell in the column you want filtered new sheets for", "Select a column", "$I$1", , , , , 8)
On Error GoTo here
If Not Response Is Nothing Then
  Application.ScreenUpdating = False
  Set OrigSht = Response.Parent
  With OrigSht
    Set Response = .Cells(1, Response.Column)
    Set RangeToFilter = Intersect(.UsedRange, Response.EntireColumn)
'Set RangeToFilterData = RangeToFilter.Offset(1).Resize(RangeToFilter.Rows.Count - 1)
    Set uniqueSht = Sheets.Add(After:=Sheets(Sheets.Count))
    RangeToFilter.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=uniqueSht.Range("A1"), Unique:=True
    Set uniquerng = uniqueSht.UsedRange
    For Each cll In uniquerng
      cll.Value = Application.Trim(cll.Value)
      If Len(cll.Value) = 0 Then cll.Value = " "
    Next cll
    uniquerng.RemoveDuplicates Columns:=1, Header:=xlYes
    Set uniquerng = uniqueSht.UsedRange
    Set uniquerng = uniquerng.Offset(1).Resize(uniquerng.Rows.Count - 1)
    For Each cll In uniquerng
      RangeToFilter.AutoFilter Field:=1, Criteria1:=cll.Value
      Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
      OrigSht.UsedRange.Copy
      newsht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      OrigSht.UsedRange.Copy newsht.Range("A1")
'get new sheet name:
      newshtName = Application.Trim(Response.Value & " " & IIf(cll.Value = " ", "(blanks)", cll.Value))
'remove illegal sheet name characters:
      For i = 1 To 7
        newshtName = Replace(newshtName, Mid(":\/?*[]", i, 1), vbNullString)
      Next i
'name the sheet:
      newsht.Name = Right(newshtName, 31)
    Next cll
  End With
  RangeToFilter.AutoFilter
  Application.DisplayAlerts = False
  uniqueSht.Delete
  Application.DisplayAlerts = True
  MsgBox "Done"
End If
here:
Application.ScreenUpdating = True
End Sub
 
p45cal said:
You have data which includes many spaces like:
"N31~~~~~~~~~~~~~~~~~~"
(where a "~" represents a space) and like this (without spaces):
"N31"
My unique filtering treats them as different, Autofilter treats them the same.

You also have entries which are just 40 spaces which are also treated as blanks by the Autofilter.

Either remove the extra spaces from the data or use this adjusted macro below.
Code: 
Sub blah()
Dim Response As Range
On Error Resume Next
Set Response = Application.InputBox("Select any cell in the column you want filtered new sheets for", "Select a column", "$I$1", , , , , 8)
On Error GoTo here
If Not Response Is Nothing Then
  Application.ScreenUpdating = False
  Set OrigSht = Response.Parent
  With OrigSht
    Set Response = .Cells(1, Response.Column)
    Set RangeToFilter = Intersect(.UsedRange, Response.EntireColumn)
'Set RangeToFilterData = RangeToFilter.Offset(1).Resize(RangeToFilter.Rows.Count - 1)
    Set uniqueSht = Sheets.Add(After:=Sheets(Sheets.Count))
    RangeToFilter.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=uniqueSht.Range("A1"), Unique:=True
    Set uniquerng = uniqueSht.UsedRange
    For Each cll In uniquerng
      cll.Value = Application.Trim(cll.Value)
      If Len(cll.Value) = 0 Then cll.Value = " "
    Next cll
    uniquerng.RemoveDuplicates Columns:=1, Header:=xlYes
    Set uniquerng = uniqueSht.UsedRange
    Set uniquerng = uniquerng.Offset(1).Resize(uniquerng.Rows.Count - 1)
    For Each cll In uniquerng
      RangeToFilter.AutoFilter Field:=1, Criteria1:=cll.Value
      Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
      OrigSht.UsedRange.Copy
      newsht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      OrigSht.UsedRange.Copy newsht.Range("A1")
'get new sheet name:
      newshtName = Application.Trim(Response.Value & " " & IIf(cll.Value = " ", "(blanks)", cll.Value))
'remove illegal sheet name characters:
      For i = 1 To 7
        newshtName = Replace(newshtName, Mid(":\/?*[]", i, 1), vbNullString)
      Next i
'name the sheet:
      newsht.Name = Right(newshtName, 31)
    Next cll
  End With
  RangeToFilter.AutoFilter
  Application.DisplayAlerts = False
  uniqueSht.Delete
  Application.DisplayAlerts = True
  MsgBox "Done"
End If
here:
Application.ScreenUpdating = True
End Sub
Click to expand...

Thanks it work fine
it helps a lot
thanks again
 
You must log in or register to reply here.
Back
Top