Seach Named Range for value if there then else

[Mozzz]

I am working on a workers comp report. I have a list of all the employee names, comp code, dept code on Sheet 2 named Dept_rng. To clarify, the list is named "Dept_rng" which resides on Sheet 2.

On Sheet 1, I have the Employee Names with Payroll info. I also have blank rows that will return an error if I apply the formulas needed to calculate the worker comp for a specific employee designated by a specific row Cells(i , 1).

I need to search the Named Range on Sheet 2 "Dept_rng" for the name on page one, one cell(Cells(i , 1) at a time. If find the name on Sheet one in Dept_rng Sheet2 is not found than Next i. If it is there then add formula to rows on Sheet 1.

Here is the best I have come up with which does not work.

Sub PostFormulas()
'   Search NameRange for EmployeeName if Error Go to next line
 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
 
    On Error Resume Next
    Names.Add Name:="EmpName", RefersTo:=Sheets(2).Range("A2:A70")
 
    For i = 12 To FinalRow
        MyVariable = Cells(i, 1)
        Sheets(2).Range("EmpName").Find(What:=MyVariable, LookAt:=xlWhole, _
            LookIn:=xlValues) = x
        Sheets(2).Range("L2:O2").Copy Destination:=Sheets(1).Cells(i, 10)
 
 
 
    Next i
 
End Sub

Suggestions Please

Thanks,

Mozzz

 

[GlennUK]

Firstly, can I ask whether there is an employee reference number? Searching by name seems rather dangerous ( we had 3 John Smiths where I used to work, in the same department ).

 

[Mozzz]

Unfortunately not. The name which is exact is the reference. We actually assign Dept, code, and emp # from the name. This is a rinky-dink payroll program that does the bare necessities. Total Cost of payroll per month for 49 employees is $40.00. This includes fuduciary on the taxes adn 401K. I actually just go done writing a VBA Macro to do the in-house payroll entry. Again, the report we get does not give Dept#, Employ#, or Account #. It only gives ###-###-1234 SS and the Employee name. Since this posting I have completed the Wrkr Comp Macro. Here it is:

Sub WorkerCompStep1()
'
' WorkerCompStep1 Macro
'
'
'   Import Sheet to Template
    Sheets("Sheet").Copy Before:=Workbooks("A-WkrComp Template.xlsm").Sheets(1)
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Cells.Select
  
    Selection.UnMerge
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Columns("G:G").Select
  
    Selection.Delete Shift:=xlToLeft
    Columns("A:I").Select
    Columns("A:I").EntireColumn.AutoFit
    Range("A6:I12").Select
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "RegHrs"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "RegAmt"
    Range("D7").Select
    ActiveCell.FormulaR1C1 = "OT-Hrs"
    Range("E7").Select
    ActiveCell.FormulaR1C1 = "OT-Amt"
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "OthrHrs"
    Range("G7").Select
    ActiveCell.FormulaR1C1 = "OthrAmt"
    Range("H7").Select
    ActiveCell.FormulaR1C1 = "OthrWage"
    Range("I7").Select
    ActiveCell.FormulaR1C1 = "TotAmt"
    Range("H6").Select
    
'   Search NameRange for EmployeeName if Error Go to next line
    
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    On Error Resume Next
'    Names.Add Name:="EmpName", RefersTo:=Sheets(2).Range("A2:A70")
    
   Sheets(2).Range("L1:O1").Copy Destination _
                :=Sheets(1).Range("J7")
    
    For i = 8 To FinalRow
                Sheets(2).Range("L2:O2").Copy Destination _
                :=Sheets(1).Cells(i, 10)
    Next i
    
'   Set up pivot Table
    Dim WSD As Worksheet
    Dim PTCache As PivotCache
    Dim PT As PivotTable
    Dim PRange As Range
'    Set WSD = Worksheets("PivotTable")
    On Error Resume Next
'   Delete any prior pivot tables
    For Each PT In PivotTables
        PT.TableRange2.Clear
    Next PT
    
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    FinalColumn = Cells(7, Columns.Count).End(xlToLeft).Column
    Set PRange = Cells(7, 1).Resize(FinalRow, FinalColumn)
    
        
   'Create the Cache
    Range("A1").Select
    Set PTCache = ActiveWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=PRange)
        
'   Add a New Worksheet for the Pivot Table
    Worksheets.Add
    
'   Create the Pivot Table
    Set PT = ActiveSheet.PivotTables.Add( _
        PivotCache:=PTCache, _
        TableDestination:=Range("A3"), TableName:="PivotTable1")
        
'   Add PivotFields
   PT.AddFields RowFields:=Array("Code")
   
'   Remove Code Items
   With PT
        .PivotFields("Code").PivotItems("#N/A").Visible = False
        .PivotFields("Code").PivotItems("(Blank)").Visible = False
    End With
    
'   Set up the data Fields
    With PT.PivotFields("TotAmt")
        .Orientation = xlDataField
        .Function = xlSum
        .Position = 1
        .NumberFormat = "#,##0.00"
        .Name = "TotlAmt"
    End With
    
    With PT.PivotFields("OT-Amt")
        .Orientation = xlDataField
        .Function = xlSum
        .Position = 2
        .NumberFormat = "#,##0.00"
        .Name = "OT-Amt"
    End With
    With PT.PivotFields("Amount")
        .Orientation = xlDataField
        .Function = xlSum
        .Position = 3
        .NumberFormat = "#,##0.00"
        .Name = "AmtDue"
    End With
    
    '   Copy Pivot with Codes then run Pivot with Dept
    Range("A4").CurrentRegion.Copy
    Range("A14").PasteSpecial xlPasteValuesAndNumberFormats
    
    Application.CutCopyMode = False
    
    PT.PivotFields("Code").Orientation = xlHidden
    PT.PivotFields("Dept").Orientation = xlRowField
    
     With PT
        .PivotFields("Dept").PivotItems("#N/A").Visible = False
        .PivotFields("Dept").PivotItems("(Blank)").Visible = False
    End With
End Sub

 

[GlennUK]

Is this any help:

Sub PostFormulas()
'   Search NameRange for EmployeeName if Error Go to next line
 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
 
    On Error Resume Next
    Names.Add Name:="EmpName", RefersTo:=Sheets(2).Range("A2:A70")
 
    For i = 12 To FinalRow
        MyVariable = Cells(i, 1)
        Set x = Sheets(2).Range("EmpName").Find(What:=MyVariable, LookAt:=xlWhole, _
            LookIn:=xlValues)
        If Not x Is Nothing Then
            x.Offset(0, 11).Resize(1, 4).Copy Destination:=Sheets(1).Cells(i, 10)
 
        End If
 
    Next i
 
End Sub

?