Dividing data into different tabs

[Lulu1000]

Hi all,

I am very new to this website so apologies if I have done anything wrong. I am also a very basic user in excel so for anything really technical I may need clear steps (Sorry!).

I have a spreadsheet similar to the uploaded picture. What I am trying to do is have a new tab for every supervisor name (column D) I can do this by just filtering the sheet and copying on to new tabs, however, I am looking for a way that this is automatic. each month I will transferring data over to sheet one and need new tabs for each supervisor so hoping there is a way that I can get it to automatically look through sheet one and only return details for a certain supervisor. In this example it would be one tab for Gary and one tab for Laura but I need all the columns to come through. I have tried lookups but I can not seem to get it right. any help would be amazing thank you very much.

 

[dmt32]

Hi,
welcome to forum

Try following & see if it does what you want

place code in a STANDARD module (Alt+F11)

Option Explicit
Sub FilterColumn()
    'dmt32 aug 2020
    Dim wsData      As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng     As Range, FilterRange As Range
    Dim rowcount    As Long
    Dim FilterCol   As Variant
    Dim SheetName   As String
  
    On Error GoTo progend
   
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Raw Data")
  
'Column you are filtering
    FilterCol = "D"
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
  
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
      
        Set Datarng = .Range("A1").CurrentRegion
      
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).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)
            SheetName = CStr(Left(FilterRange.Text, 31))
'check for blank cell in range
            If SheetName <> "" Then
'add the FilterRange to criteria
'part matches
                'wsFilter.Range("B2").Value = FilterRange.Value
'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & SheetName & """"
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If

'size column widths to match master
'NB - slows code down a little
            Datarng.Rows(1).Copy
            wsNames.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths
'clear from memory
            Set wsNames = Nothing
'clear clipboard
            Application.CutCopyMode = False
        Next
        .Select
    End With
  
progend:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
  
    If Err <> 0 Then MsgBox (Error(Err)), vbCritical, "Error"
      
End Sub

If code does go in right direction, it can be made to run automatically each time you open the workbook to refresh the data otherwise, and if not quite what you want, there are plenty here to offer further suggestions.

Hope Helpful

Dave

 

[Lulu1000]

Hi,
welcome to forum

Try following & see if it does what you want

place code in a STANDARD module (Alt+F11)

Option Explicit
Sub FilterColumn()
    'dmt32 aug 2020
    Dim wsData      As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng     As Range, FilterRange As Range
    Dim rowcount    As Long
    Dim FilterCol   As Variant
    Dim SheetName   As String
 
    On Error GoTo progend
  
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Raw Data")
 
'Column you are filtering
    FilterCol = "D"
 
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
 
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
     
        Set Datarng = .Range("A1").CurrentRegion
     
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).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)
            SheetName = CStr(Left(FilterRange.Text, 31))
'check for blank cell in range
            If SheetName <> "" Then
'add the FilterRange to criteria
'part matches
                'wsFilter.Range("B2").Value = FilterRange.Value
'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & SheetName & """"
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If

'size column widths to match master
'NB - slows code down a little
            Datarng.Rows(1).Copy
            wsNames.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths
'clear from memory
            Set wsNames = Nothing
'clear clipboard
            Application.CutCopyMode = False
        Next
        .Select
    End With
 
progend:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
 
    If Err <> 0 Then MsgBox (Error(Err)), vbCritical, "Error"
     
End Sub

If code does go in right direction, it can be made to run automatically each time you open the workbook to refresh the data otherwise, and if not quite what you want, there are plenty here to offer further suggestions.

Hope Helpful

Dave

This worked fantastically thank you!!!! do you know how to get it to run after you change the data on the first sheet? So it will run when I upload new data?

Again thank you so much for this didnt even know where to start

 

[dmt32]

This worked fantastically thank you!!!! do you know how to get it to run after you change the data on the first sheet? So it will run when I upload new data?

Again thank you so much for this didnt even know where to start

Glad suggestion does what you want

Simplest way to update would be to place a button on your master sheet & assign it to the macro.
You can then press button to perform the update after you have made all the changes.

Dave

 

[Lulu1000]

Glad suggestion does what you want

Simplest way to update would be to place a button on your master sheet & assign it to the macro.
You can then press button to perform the update after you have made all the changes.

Dave

Thank you,