You could try this:
Sub hotherpsTest5()
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$E$24=$AK$1,$AK2=""X"",$E$34>$E$25),$E$24,"""")"
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$F$24=$AL$1,$AL2=""X"",$F$34>$F$25),$F$24,"""")"
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$G$24=$AM$1,$AM2=""X"",$G$34>$G$25),$G$24,"""")"
Dim Temp As String ' temporary storage area for "base" cell
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Range("D2:AJ17").Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$E$24=$AK$1,$AK2=""X"",$E$34>$E$25),$E$24,"""")"
Range("D2:AJ17").Value = Range("D2:AJ17").Value ' convert formulae to values
Temp = Range("D2") ' store "base" cell
Range("D2") = "" ' clear "base" cell
Range("D2:AJ17").SpecialCells(xlCellTypeBlanks).Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$F$24=$AL$1,$AL2=""X"",$F$34>$F$25),$F$24,"""")"
Range("D2") = Temp ' restore "base" cell
Range("D2:AJ17").Value = Range("D2:AJ17").Value ' convert formulae to values
Temp = Range("D2") ' store "base" cell
Range("D2") = "" ' clear "base" cell
Range("D2:AJ17").SpecialCells(xlCellTypeBlanks).Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$G$24=$AM$1,$AM2=""X"",$G$34>$G$25),$G$24,"""")"
Range("D2") = Temp ' restore "base" cell
Range("D2:AJ17").Value = Range("D2:AJ17").Value ' convert formulae to values
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I need to clear the "base" cell (D2) in order to select the empty cells in
the range and drop the "sample" formula in. I then restore the value to
cell D2 in order to ensure the second and third calculations reflect the
original value. I'm not 100% confident in this approach but it generates
Picks and Packs, not Alps (whatever that is).
It might be safer to insert a blank line before the Employee data and
include that in the range. This new row 2 would never meet the formulae
conditions so should always stay blank and not interfere with any
calculations. You could delete Row 23 so that the ranges in the code don't
all have to change. The code for this would then look like:
Sub hotherpsTest6()
' note: needs a new blank row to be inserted at row 2 before the employee
data
' AND row 23 deleting to compensate.
' the range also needs extending to include row 18
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$E$24=$AK$1,$AK2=""X"",$E$34>$E$25),$E$24,"""")"
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$F$24=$AL$1,$AL2=""X"",$F$34>$F$25),$F$24,"""")"
'
"=IF(AND(D$1>=$B2,D$1<=$C2,$G$24=$AM$1,$AM2=""X"",$G$34>$G$25),$G$24,"""")"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Range("D2:AJ18").SpecialCells(xlCellTypeBlanks).Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$E$24=$AK$1,$AK2=""X"",$E$34>$E$25),$E$24,"""")"
Range("D2:AJ18").Value = Range("D2:AJ18").Value ' convert formulae to values
Range("D2:AJ18").SpecialCells(xlCellTypeBlanks).Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$F$24=$AL$1,$AL2=""X"",$F$34>$F$25),$F$24,"""")"
Range("D2:AJ18").Value = Range("D2:AJ18").Value ' convert formulae to values
Range("D2:AJ18").SpecialCells(xlCellTypeBlanks).Formula = _
"=IF(AND(D$1>=$B2,D$1<=$C2,$G$24=$AM$1,$AM2=""X"",$G$34>$G$25),$G$24,"""")"
Range("D2:AJ18").Value = Range("D2:AJ18").Value ' convert formulae to values
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This is also a bit neater ... still seems to work which is good
One disadvantage with all these options is that the range will need manually
adjusting if you add employees or move the tables at the bottom ... but one
step at a time
Regards
Trevor