Results 1 to 5 of 5

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

  1. #1

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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
    Attached Files Attached Files

  2. #2
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,356
    Articles
    0
    Excel Version
    365
    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
    Attached Files Attached Files

  3. #3
    Quote Originally Posted by p45cal View Post
    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

    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
    Attached Files Attached Files

  4. #4
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,356
    Articles
    0
    Excel Version
    365
    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

  5. #5
    Quote Originally Posted by p45cal View Post
    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
    Thanks it work fine
    it helps a lot
    thanks again

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •