Find records in different sheets

Option Explicit

Sub MoveDataFromMasterToValueBasedSheet()
' Syed Asad Ali Rizvi
' Version 2.0
Dim sMasterSheet As String 'name of the master sheet
Dim iBasedOnColumn As Integer 'column number based on which sheets are to be generated
Dim bReplace As Boolean ' should new sheet be generated for item based on which data is cut
Dim lHeaderRowLocation As Long ' first used row which should be the header row too

Dim lMaxUniqueValueCount As Long 'number of unique items on which sheets are to be generated
Dim iUniqueItemProcess As Long ' unique item count that is being processed
Dim sUniqueValue As String ' the value for which the sheet is being generated


Dim bFreshSheet As Boolean ' fresh sheet was created for item
Dim sTempSheet As String 'name of a temp sheet for purpose of working
Dim sTempSheet2 As String 'temp sheet to compare columns in source and target
Dim lResultSheet As Long 'number of rows in the new sheet
Dim iFilterCol As Integer 'location of columns on master sheet
Dim iResultCol As Integer 'location of column on target sheet

Dim bScreenUpdating As Boolean 'current status of screen updating
Dim bDisplayAlerts As Boolean ' show show warnings

Dim LastRow As Long

    bScreenUpdating = Application.ScreenUpdating
    bDisplayAlerts = Application.DisplayAlerts
    
    On Error GoTo Error_Handle
    
    Application.ScreenUpdating = False
    
    
    ' ===============================================
    ' ######### CUSTOMIZATION START HERE ############
    
    sMasterSheet = "Sheet1" ' master sheet
    iBasedOnColumn = 1 ' unique items on which data would be cut is would on master sheet in this column
    lHeaderRowLocation = 1 'the row on which the header row is found and is common to all sheets
    bReplace = True 'should data be cut/copied on new sheets if sheet is present. This would delete previous instance of that sheet?
    
    ' ######### CUSTOMIZATION END HERE #############
    ' ===============================================
    
    sTempSheet = "tempsheet" ' temp sheet for unique listing based on which sheets would be populated
    sTempSheet2 = "tempsheet2" '
    bFreshSheet = False ' if data was not to be cut on new sheet, was this sheet created as it was not present
    
    On Error Resume Next
        If bDisplayAlerts Then Application.DisplayAlerts = False
        Sheets(sTempSheet).Delete
        If (Not bReplace) Then Sheets(sTempSheet2).Delete
         If bDisplayAlerts Then Application.DisplayAlerts = True
    On Error GoTo Error_Handle
    
    Sheets.Add
    ActiveSheet.Name = sTempSheet
    
    Sheets(sMasterSheet).Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        
        On Error Resume Next
        
        ActiveSheet.ShowAllData
        
        On Error GoTo Error_Handle
    
    End If
    
    Columns(iBasedOnColumn).Select
    Selection.Copy
    
    Sheets(sTempSheet).Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    If (Cells(1, 1) = "") Then
        LastRow = Cells(1, 1).End(xlDown).Row
        
        If LastRow <> Rows.Count Then
            Range("A1:A" & LastRow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
    
    End If
    
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    
    Columns("A:A").Delete
    
    Cells.Select
    Selection.Sort _
                Key1:=Range("A2"), Order1:=xlAscending, _
                Header:=xlYes, OrderCustom:=1, _
                MatchCase:=False, Orientation:=xlTopToBottom
    lMaxUniqueValueCount = Cells(Rows.Count, 1).End(xlUp).Row
    
    If (Not bReplace) Then
        Sheets.Add
        ActiveSheet.Name = sTempSheet2
        Sheets(sMasterSheet).Select
        Range(Cells(lHeaderRowLocation, 1), Cells(lHeaderRowLocation, Columns.Count)).Copy
        Sheets(sTempSheet2).Range("A1").PasteSpecial Transpose:=True
        
    End If
    
    For iUniqueItemProcess = 2 To lMaxUniqueValueCount
    
        sUniqueValue = Sheets(sTempSheet).Range("A" & iUniqueItemProcess)
        bFreshSheet = False
        If sUniqueValue <> "" Then
        
            On Error Resume Next
                Err.Clear
                Sheets(sUniqueValue).Select
            On Error GoTo Error_Handle
                
            If ((ActiveSheet.Name <> sUniqueValue) Or (bReplace)) Then
                
                On Error Resume Next
                    If bDisplayAlerts Then Application.DisplayAlerts = False
                    Sheets(sUniqueValue).Delete
                    If bDisplayAlerts Then Application.DisplayAlerts = True
                On Error GoTo Error_Handle
                
                Err.Clear
                Sheets.Add
                ActiveSheet.Name = sUniqueValue
                Sheets(sUniqueValue).Range(lHeaderRowLocation & ":" & lHeaderRowLocation) = Sheets(sMasterSheet).Range(lHeaderRowLocation & ":" & lHeaderRowLocation).Value
                bFreshSheet = True
                
            End If
            
            If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
            lResultSheet = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lResultSheet = lResultSheet + 1
            Cells(lResultSheet, "A").Select
            
            Sheets(sMasterSheet).Select
            Range(Cells(lHeaderRowLocation, 1), Cells(Rows.Count, Columns.Count)).Select
            
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
            
            Selection.AutoFilter Field:=iBasedOnColumn, Criteria1:="=" & sUniqueValue, Operator:=xlAnd, Criteria2:="<>"
            
            LastRow = Cells(Rows.Count, iBasedOnColumn).End(xlUp).Row
            
            If (LastRow > lHeaderRowLocation) Then
            
                If bFreshSheet Then
                    Rows(lHeaderRowLocation + 1 & ":" & LastRow).Copy
                    Sheets(sUniqueValue).Range("A" & lResultSheet).PasteSpecial
                Else
                
                    lResultSheet = Sheets(sUniqueValue).Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lResultSheet = lResultSheet + 1
                    Sheets(sUniqueValue).Select
                    Range(Cells(lHeaderRowLocation, 1), Cells(lHeaderRowLocation, Columns.Count)).Copy
                    Sheets(sTempSheet2).Select
                    Sheets(sTempSheet2).Range("B1").PasteSpecial Transpose:=True
                    iResultCol = Cells(Rows.Count, "B").End(xlUp).Row
                    
                    Do While (iResultCol > 0)
                        iFilterCol = 0
                        
                        On Error Resume Next
                        iFilterCol = WorksheetFunction.Match(Sheets(sTempSheet2).Cells(iResultCol, "B"), Sheets(sTempSheet2).Range("A1:A" & Rows.Count), 0)
                        On Error GoTo Error_Handle
                        
                        If (iFilterCol > 0) Then
                            Sheets(sMasterSheet).Select
                            Range(Cells(lHeaderRowLocation + 1, iFilterCol), Cells(LastRow, iFilterCol)).Copy
                            Sheets(sUniqueValue).Select
                            Cells(lResultSheet, iResultCol).Select
                            ActiveSheet.PasteSpecial
                            
                            
                        End If
                        
                        iResultCol = iResultCol - 1
                        
                    Loop
                    
                    Sheets(sUniqueValue).Select
                    Cells(lResultSheet, 1).Select
                End If
                
            End If
        End If
    
    Next
    
    If bDisplayAlerts Then Application.DisplayAlerts = False
        Sheets(sTempSheet).Delete
        If (Not bReplace) Then Sheets(sTempSheet2).Delete
    If bDisplayAlerts Then Application.DisplayAlerts = True
    
    Sheets(sMasterSheet).Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

    GoTo End_Sub
    
Error_Handle:

    MsgBox Err.Description
    
End_Sub:

    Application.ScreenUpdating = bScreenUpdating
    Application.DisplayAlerts = bDisplayAlerts
    
End Sub