Maccro to Create and Populate new sheets based on value in Column

[Simplemountain]

Ok,

I know that this is a subject that comes up over and over again and I assure you that I have spent countless hours going over posts that answer this question in different ways. Yet, I am having some true difficulty putting all of the pieces together to create a macro that works the way I truly need. I am repeatedly amazed at the charity of the people on this forum and want to say thank you to everyone who contributes and is involved. It is truly an incredible resource. Thank you!!


So here is where I'm at:
I have some raw data that is imported into an excel sheet from an external program for instruments that require calibration (about 1000 or so) I call this sheet the master. The data contains rows which represent one item. Each item has several columns of information pertinent to that item (serial#, Calibration date, description, etc...). I am working on breaking the data down into separate sheets based on departments so that each department can easily see what instruments are coming due for calibration. Currently there is no designation for department but I will gradually update the data to include column "L" which will represent the department each item belongs to. I am trying to create a macro that looks at column "L" and creates a sheet for each department and then populates the data from the master sheet into the department sheet for each item that belongs there.

currently I have the following macro:

Sub MigrateData()




Application.ScreenUpdating = False


Dim lRow As Long
Dim MySheet As String
lRow = Range("A" & Rows.Count).End(xlUp).Row


For Each sht In Worksheets
If sht.Name <> "Master" Then
sht.UsedRange.Offset(1).ClearContents
End If
Next sht


For Each cell In Range("L6:L" & lRow)
MySheet = cell.Value
cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next cell


Application.ScreenUpdating = True
Application.CutCopyMode = False


End Sub

This works great for populating data to a known sheet name.

I would like the macro to eventually do this:

The workbook begins with one sheet (sheet 1) called 'Master' containing the raw data. The macro will create new sheets based on a known list (Dept 1, Dept 2, Dept 3, etc...) There will also be an additional sheet called unclassified. The macro will then look at column "L" on the master sheet. This column will have a value that corresponds to the known department names (Dept 1, Dept 2, Dept 3, etc...) For any value that is the same as a known department name it will then copy that row to the appropriate sheet of the same name. For any value that is blank or not equal to one of the predetermined sheet names, it will copy that row into the sheet labeled 'unclassified'. I picture this being something to the effect of 'On error, copy row to unclassified'

The reason for all of this is that I will be assigning departments over a stretch of time and need to be able to split the data to each department sheet they are assigned to while also having a sheet that includes all of the items that are not currently assigned to a department.

Eventually, I will also be attempting to get the final data on each sheet into a table format so that I can easily reorganize the data based on the value of each column. The end game is to have conditional formating for the calibration due date (column "H") on each sheet that colors a cell based on how soon calibration is required. This will allow each department to see exactly what equipment needs to be looked at on a monthly basis. I will be generating new sheets based on the raw data monthly which is why I am trying to streamline the process using VBA.

Thank you in advance to any and all who read through all of this and have any ideas!!

 

[dmt32]

Hi,
Assuming that your master sheet has field name headings then give this a try & see if helps:

Place code in a STANDARD module.

Option Explicit
Sub FilterData()
    'DMT32
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String




    'master sheet
    Set ws1Master = ActiveSheet


    'set the Column you
    'are filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If


    FilterCol = objRange.Column
    FilterRow = objRange.Row


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


    On Error GoTo progend


    'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column


        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If


        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).Replace "", "Unclassified"
        
        'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
                      Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
                      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
        'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value


        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
        
            'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
            
                'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
            
                SheetName = Trim(Left(FilterRange.Value, 31))
            
                On Error Resume Next
                Set wsNew = Worksheets(SheetName)
                If Err > 0 Then
                    'add new sheet
                    Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                    Err.Clear
                End If
                
                On Error GoTo progend
                
                wsNew.Cells.ClearContents
                
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                                       CopyToRange:=wsNew.Range("A1"), Unique:=False


            
                wsNew.UsedRange.Columns.AutoFit
            End If
            
            Set wsNew = Nothing
        Next
        
        .Select
    End With


progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

When run, you will be presented with an InputBox - Select with mouse the Field HEADING you want to filter & press OK button.

The code will filter each record in that column to a sheet with the same name. If the sheet does not exists it will be created. For blank cells in the range, these will be replaced as "Unclassified" and filtered to that sheet.
When you update master & run code, all sheets will be updated accordingly.

Hope Helpful

Dave

 

[Simplemountain]

Thank you Dave! This is incredible!

I am getting an error message when I run the code 'Object Variable or With Block Variable not set'

It appears to me to be connected to creating new sheets.

I have managed to get it to work by running to cursor in the debugger. Once all of the new sheets are created I can then change the master and run the code with no issues unless I change one of the values in the filter column to something unique again. Then I get the same error message.

Any thoughts on what that might be?

I really appreciate your time on this, I am very very impressed with your solution. It is well beyond my own ability.

Once I get the error worked out I will attempt to tweak it a little. I think a section to clear all of the existing sheets besides the master first for trouble shooting and some way to get the new sheets into a printer friendly format with a department title and print date. followed by the imported data in a table format so that I can sort them by different columns as needed.

 

[dmt32]

I adapted code slightly to accommodate your unclassified requirement but other than that, code has been used many times by others here & performed ok before posting.

Without seeing your data can only guess but you should ensure that values in cells make legal sheet names & if this is the issue try following:

Change this line:

SheetName = Trim(Left(FilterRange.Value, 31))

To This:

SheetName = IsValidTabName(FilterRange.Value)

Add this function to a standard module:

Function IsValidTabName(ByVal TabName As String) As String
    Dim IllegalChar
    Dim x as Integer


    'check for illegal characters
    IllegalChar = Array("[", "]", "/", "*", "\", "?")


    For x = LBound(IllegalChar) To UBound(IllegalChar)
        TabName = Replace(TabName, IllegalChar(x), "_", 1)
    Next x
    
    'check sheet tab name char limit
    TabName = Left(TabName, 31)


    IsValidTabName = TabName


End Function

and see if this helps.


if still have issues & can post copy of workbook with sample data to a dropbox, will have a look for you.

Dave

 

[Simplemountain]

Once again, thank you for your time.

Please see this link
https://www.dropbox.com/s/c7do1z8ob1osaxz/Calibration Test.xlsm?dl=0

for what I am working with. I made the suggested changes and still am getting the error message. I don't doubt it is something benign about the way I have set everything up.

 

[dmt32]

Once again, thank you for your time.

Please see this link
https://www.dropbox.com/s/c7do1z8ob1osaxz/Calibration Test.xlsm?dl=0

for what I am working with. I made the suggested changes and still am getting the error message. I don't doubt it is something benign about the way I have set everything up.

Hi,
code runs fine for me however, question I neglected to ask is have you protected the workbook? If so, unprotect it & see if that solves the problem.

Dave