Results 1 to 3 of 3
  1. #1
    New Lounger
    Join Date
    Jul 2016
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Create Sheets by Month

    Dears Good Day ,
    I have excel file , in main data sheet I enter Data by this code it will create Range of sheets depending on (column 4).. i want to make my code create another range of sheets depending on date(column 3) (for each month create sheet). that mean 2 range of sheets one depending on city(column 4) and another one depending on month (column 3) Can Anyone Edit My Code(Because i don't know to change this code) Thanks in Advance .

    Code:
    Option Explicit
    
    Sub ExtractToSheets()
      
        Dim ws    As Worksheet
        Dim wsNew As Worksheet
        Dim rData As Range
        Dim rCl   As Range
        Dim sNm   As String
        
        Set ws = Sheet1
        
        'extract a list of unique names
        'first clear existing list
        
        With ws
        
            Set rData = .Range("A1").CurrentRegion
            .Columns(.Columns.Count).Clear
            rData.Columns(4).AdvancedFilter Action:=xlFilterCopy, _
                                            CopyToRange:=.Cells(1, .Columns.Count), _
                                            Unique:=True
            
            For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
            
              sNm = rCl.Text
              
              'add new sheet (only if required-NB uses UDF)
              
              If WksExists(sNm) Then
                'so clear contents
                Sheets(sNm).Cells.Clear
              Else
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
                wsNew.Name = sNm
              End If
              
              'AutoFilter & copy to relevant sheet
              rData.AutoFilter Field:=4, Criteria1:=sNm
              rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
            
            Next rCl
              
        End With
          
        ws.Columns(Columns.Count).ClearContents 'remove temporary list
        rData.AutoFilter 'switch off AutoFilter
        
    End Sub
          
    Function WksExists(wksName As String) As Boolean
        
      On Error Resume Next
      WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
          
    End Function

    main.jpg
    Last edited by RetiredGeek; 2016-07-24 at 12:21. Reason: Replaced code with indents and syntax corrected.

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Pashew,

    Welcome to the Lounge as a new poster!

    I've replaced your code block as it contained a lot of formatting codes for the bbs which should not be included in code blocks as it makes them hard to copy for testing. I also added indenting to make the structure easier to understand.

    Not knowing exactly what is going on (it always helps if you can post actual workbooks vs just pictures) here's a general routine to create new sheets based on Month.
    Code:
    Sub NewMonths()
    
        Dim ws    As Worksheet
        Dim wsNew As Worksheet
        Dim rData As Range
        Dim rCl   As Range
        Dim sNm   As String
    
    Set ws = ActiveSheet
    
    [C2].Select
    
    Do
    
        sNm = Month(ActiveCell)
         
        If (Not WksExists(sNm)) Then
           'new sheet required
           Set wsNew = Sheets.Add(After:=Worksheets(Worksheets.Count))  'move to end
           wsNew.Name = sNm
           ws.Activate
        End If
    
        ActiveCell.Offset(1, 0).Select
    
    Loop Until ActiveCell.Value = ""
    
    End Sub
    Note: The code was setup as a standalone routine for testing but can be easily integrated into your existing code.

    You don't mention how you want the sheets names so I just assumed you wanted the numbered. You could create an array of month names and use the Month number to index into them for more readable sheet names. If you want to do this just post back if you need help.

    HTH
    Last edited by RetiredGeek; 2016-07-24 at 12:45.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Pashew,

    Here is the code if you want the sheets names with text.
    Code:
    Sub NewMonths()
    
        Dim ws    As Worksheet
        Dim wsNew As Worksheet
        Dim rData As Range
        Dim rCl   As Range
        Dim sNm   As String
        Dim vMons As Variant
        
    
        vMons = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                      "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
        
    Set ws = ActiveSheet
    
    [C2].Select
    
    Do
    
        sNm = vMons(Month(ActiveCell) - 1) '*** vMons is a Zero based array! ***
         
        If (Not WksExists(sNm)) Then
           'new sheet required
           Set wsNew = Sheets.Add(After:=Worksheets(Worksheets.Count))  'move to end
           wsNew.Name = sNm
           ws.Activate
        End If
    
        ActiveCell.Offset(1, 0).Select
    
    Loop Until ActiveCell.Value = ""
    
    End Sub
    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Tags for this Thread

Posting Permissions

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