Loop through Range and Force Formula Calculation

[reberryjr]

I am in need of some help here. I'm trying to cycle through a range of cells, copying a value (someone's name) and pasting it into a cell on another worksheet. Once the name is pasted on the other worksheet, it should force formulas to calculate (auto-calculation is off for performance). What I'm seeing in some instances, is that the output is incorrect. I will see values of 2 or 4 when the data only supports a value of 1 or 2. If I manually change the name, the values displayed are accurate. I added a 1 second delay in the code today, hoping the issue is that the code was trying to "run too fast".

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim m As Workbook
Dim mS As Worksheet

Set m = ThisWorkbook
Set mS = m.Sheets("Scorecard")

If Not Intersect(Target, Range("B2")) Is Nothing Then
    mS.Calculate
    mS.Columns.AutoFit
End If

If Not Intersect(Target, Range("B5")) Is Nothing Then
    mS.Calculate
    Application.Wait (Now + TimeValue("00:00:01"))'---I just added this line today.
    mS.Columns.AutoFit
End If

End Sub

Option Explicit
Sub CreateLScorecards()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim m As Workbook, n As Workbook
Dim mS As Worksheet, mD As Worksheet, nP1 As Worksheet, nP2 As Worksheet, nProd As Worksheet, nD As Worksheet, nS As Worksheet
Dim c As Range
Dim uDP As String, fP As String, fN As String
Dim mDLR As Long

Set m = ThisWorkbook
Set mS = m.Sheets("S")
Set mD = m.Sheets("D")

mDLR = mD.Range("AB" & Rows.Count).End(xlUp).Row

uDP = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\L\"

If (Dir(uDP & "SC Template.xlsx") = "") Then
    Set n = Workbooks.Open("Masked Intentionally Template.xlsx")
    n.SaveAs Filename:=uDP & "SC Template.xlsx"
    n.Close
Else
    GoTo Process
End If

Process:
For Each c In mD.Range("AB2:AB" & mDLR)

    Set n = Workbooks.Open(uDP & "SC Template.xlsx")
    If n.AutoSaveOn Then n.AutoSaveOn = False
    Set nP1 = n.Sheets("PMI_1")
    Set nP2 = n.Sheets("PMI_2")
    Set nProd = n.Sheets("Prod")
    Set nD = n.Sheets("DA")
    Set nS = n.Sheets("SL")

    c.Copy
        mS.Range("B5").PasteSpecial (xlPasteValues)
        
        Application.Wait (Now + TimeValue("00:00:01")) '---I just added this line today.

    mS.Range("A1:B12").Copy
        nP1.Range("A1").PasteSpecial (xlPasteValues)
        nP2.Range("A1").PasteSpecial (xlPasteValues)
        nProd.Range("A1").PasteSpecial (xlPasteValues)
        nD.Range("A1").PasteSpecial (xlPasteValues)
        nS.Range("A1").PasteSpecial (xlPasteValues)
        
        nP1.Range("A1").PasteSpecial (xlPasteFormats)
        nP2.Range("A1").PasteSpecial (xlPasteFormats)
        nProd.Range("A1").PasteSpecial (xlPasteFormats)
        nD.Range("A1").PasteSpecial (xlPasteFormats)
        nS.Range("A1").PasteSpecial (xlPasteFormats)
        
    mS.Range("D1:J12").Copy
        nP1.Range("D1").PasteSpecial (xlPasteValues)
        nP2.Range("D1").PasteSpecial (xlPasteValues)
        
        nP1.Range("D1").PasteSpecial (xlPasteFormats)
        nP2.Range("D1").PasteSpecial (xlPasteFormats)
        
    mS.Range("A14:Q63").Copy
        nP1.Range("A14").PasteSpecial (xlPasteValues)
        nP2.Range("A14").PasteSpecial (xlPasteValues)
        
        nP1.Range("A14").PasteSpecial (xlPasteFormats)
        nP2.Range("A14").PasteSpecial (xlPasteFormats)
        
        nP1.Range("A40:A63").EntireRow.Delete
        nP2.Range("A16:A39").EntireRow.Delete
        
    mS.Range("A65:AK74").Copy
        nProd.Range("A14").PasteSpecial (xlPasteValues)
        nProd.Range("A14").PasteSpecial (xlPasteFormats)
        
    mS.Range("A76:N125").Copy
        nD.Range("A14").PasteSpecial (xlPasteValues)
        nD.Range("A14").PasteSpecial (xlPasteFormats)
        
    mS.Range("P76:AC125").Copy
        nS.Range("A14").PasteSpecial (xlPasteValues)
        nS.Range("A14").PasteSpecial (xlPasteFormats)

    '*****Determine FilePath based on direct Manager.*****
    If nP1.Range("B8").Value <> "" Then
        fP = uDP & nP1.Range("B8").Value & "\"
    ElseIf nP1.Range("B9").Value <> "" Then
        fP = uDP & nP1.Range("B9").Value & "\"
    ElseIf nP1.Range("B10").Value <> "" Then
        fP = uDP & nP1.Range("B10").Value & "\"
    ElseIf nP1.Range("B11").Value <> "" Then
        fP = uDP & nP1.Range("B11").Value & "\"
    ElseIf nP1.Range("B12").Value <> "" Then
        fP = uDP & nP1.Range("B12").Value & "\"
    Else
        fP = uDP
    End If

    fN = nP1.Range("B5").Value & "_" & nP1.Range("B6").Value & "_" & Format(nP1.Range("B3").Value, "mm.dd.yy") & ".pdf"

    'Prints the data to a PDF file.
    n.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fP & fN, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    n.Close SaveChanges:=False

    Next c

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub