VBA to copy and move data based on multiple criteria to new sheet

[mjd]

Hello,

I have a large data set that changes often. I need to parse out by manager and administrator. There are 27 possible combinations. I am hoping to move the data, including the headers, for each manger/administrator combination to a separate tab named for that combination.

So in the main data source (a SQL connection) it'll have the 1000+ rows of data, then i'd filter for each combo (manager: abc / administrator: xyz; manager: abc / administrator: qwe; etc) and move those filtered rows to "SheetABC XYZ" or "SheetABC QWE" respectively.

Can this be done? For what its worth, the manager info is in column D and the admin data is in column E.

Thanks,
Mike

 

[dmt32]

Hi,
Does your master sheet have a row that contains headings (field names)?


Dave

 

[mjd]

Hi Dave,

It is does, row 1 is the table header.

Thanks!
Mike

 

[dmt32]

Hi Dave,

It is does, row 1 is the table header.

Thanks!
Mike

Hi,
Below is a solution I created some time ago for others here but with some changes in an attempt to accommodate your requirement to parse data based on multi fields. It’s a little cumbersome and I have not been able to fully test it but hopefully, it goes in the right direction.

The purpose of the original code was to allow in a flexible way, its use on any worksheet range data set that has headings where the need to parse data to tabs is required simply by user selecting required heading.

Place both following codes in a STANDARD module.

 Option Explicit

Sub FilterData()
'DMT32 Nov2018
    Dim ws1Master As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, objRange As Range
    Dim FilterValue As Range, FilterCriteriaRange As Range, FilterTargetRange As Range
    Dim Rowcount As Long, colcount As Long, SelectionCount As Long
    Dim FilterCol As Long, FilterRow As Long, FirstCol As Long, LastCol As Long
    Dim SheetName As String, Prompt As String
    Dim arr As Variant, Item As Variant
    
    
'master sheet
    Set ws1Master = ActiveSheet
    
    Prompt = "Select Field Name(s) To Filter" & Chr(10) & _
            "Hold Ctrl Key To Select More Than One Field Name"
    
'select the Column(s) filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox(Prompt, "Select Field Name(s)", , , , , , 8)
    On Error GoTo 0


    If objRange Is Nothing Then Exit Sub
    
    FilterCol = objRange.Column
    FilterRow = objRange.Row
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    
  On Error GoTo progend
    
'add filter sheet & intialize variables
    Set wsFilter = GetFilterSheet(objRange, SelectionCount, FilterCriteriaRange, FilterTargetRange)


    With ws1Master
        .Select
'add password if needed
        .Unprotect Password:=""
        
        Rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        FirstCol = .Cells(FilterRow, FilterCol).End(xlToLeft).Column
        LastCol = .Cells(FilterRow, FilterCol).End(xlToRight).Column
        
'check selection within data range
        If objRange.Areas(SelectionCount).Column > LastCol Then
'raise custom error
            Err.Raise 65000, "", "Filter Column Selection Is Outside Data Range.", "", 0
        End If
'master sheet data range
        'Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
        Set Datarng = .Cells(FilterRow, FirstCol).Resize(Rowcount, LastCol)
        
'extract Unique values from selected Filter Column(s) to filter sheet
        Datarng.AdvancedFilter Action:=xlFilterCopy, copytorange:=FilterTargetRange, unique:=True
        
'count no records in filter sheet
        Rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'step thru each record
        For Each FilterValue In wsFilter.Range("A2:A" & Rowcount)
            
'ignore blank cell in range
            If Len(FilterValue.Value) > 0 Then
'get sheet name
                arr = FilterValue.Resize(, SelectionCount).Value
'add the SheetName to criteria range
                wsFilter.Cells(2, SelectionCount + 2).Resize(, SelectionCount).Value = arr
                
                If IsArray(arr) Then
'two or more filter columns selected
                    For Each Item In arr
'build string name
                        SheetName = SheetName & Item & " "
                    Next
'trim name
                    SheetName = Trim(Left(Left(SheetName, Len(SheetName) - 1), 31))
                    
                Else
'single column
                    SheetName = Trim(Left(arr, 31))
                End If
                
'if sheet exists
                If Evaluate("ISREF('" & SheetName & "'!A1)") Then
'clear old data
                    Sheets(SheetName).Cells.Clear
                Else
'add new sheet & name it
'(note: no check for illegal tab name characters)
                    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = SheetName


                End If
'copy filtered data to named sheet
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FilterCriteriaRange, _
                copytorange:=Sheets(SheetName).Range("A1"), unique:=False
                
            End If


'clear variable
            SheetName = ""
        Next
        .Select
    End With
       
progend:
'delete filter sheet
    wsFilter.Delete
're-set properties
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .StatusBar = False
    End With
'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Ensure you copy this Function

Function GetFilterSheet(ByVal Target As Range, ByRef ColumnCount As Long, _
                        ByRef CriteriaRange As Range, ByRef TargetRange As Range) As Worksheet
    Dim arr() As Variant
    Dim cell As Range
    Dim i As Integer
    
    'Function Adds Temp Filter Sheet
    'enters, filter & criteria headings
    'returns,
    'Sheet object, Column Count, Filter Criteria Range
    'Filter Target Range Used To Create Unique List For Filter
    
    ColumnCount = Target.Cells.Count
    
'size array
    ReDim arr(1 To ColumnCount)
    
    For Each cell In Target.Cells
        i = i + 1
'build array from selected column header(s)
        arr(i) = cell.Value
    Next
    
'add temp filter sheet
    Set GetFilterSheet = Worksheets.Add
    
    With GetFilterSheet.Cells(1, 1).Resize(, ColumnCount)
'enter filter headers
        .Value = arr
'filter target range
    Set TargetRange = .Offset(0, 0)


       With .Offset(, ColumnCount + 1)
'criteria range headers
        .Value = arr
'filter criteria range
    Set CriteriaRange = .Resize(2, ColumnCount)
        End With
    End With
End Function

When run, you will be presented with an InputBox. SELECT the required heading(s) of column(s) that contain the data you want to parse. Hold the Ctrl key to select more than one heading.

When done press OK button

Solution is dynamic and should parse data based on your header selection(s) to sheets names that match values in selected column(s) - if sheet does not already exist, code will create a sheet with the column(s) value name. Where sheet already exists, any existing data is first cleared & then updated.

As solution uses Advanced Filter, this should be quite quick even on a large data set.

Note: Whist code has built-in general error checking, there is no code for the management of illegal tab name characters in data – code will error out if any such characters exits. If this does prove to be an issue, let me know I have a function to manage this.

Hope Helpful

Dave

 

[mjd]

Thank you Dave! Much appreciated!

 

[dmt32]

Thank you Dave! Much appreciated!

Welcome - glad solution helped

Thanks for feedback

Dave