Clean Up Code

[Legacy 436357]

Hello,

If someone has the time I would appreciate any help or suggestions to clean up the following code. It seems there are too many declarations but I am not that skilled in VBA.

Thank you very much for your help in advance.

Sub PopulateForm()
    With ThisWorkbook
        Dim myPass As String: myPass = "pass"
        Dim myPassRequest As String
        Dim myAnswer As Integer
        Dim rng As Range
        Dim rng2 As Range
        Dim i As Integer
        Dim wsSrc1 As Worksheet:    Set wsSrc1 = .Sheets("AFRsDB")
        Dim wsSrc2 As Worksheet:    Set wsSrc2 = .Sheets("AFRsParts")
        Dim wsTar As Worksheet:     Set wsTar = .Sheets("AFRsInput"):   wsTar.Unprotect "pass"
        Dim lngAFR As Long:         lngAFR = wsTar.Range("D4").Value
        Dim lngRow As Long
        Dim lngSrc2LR As Long
        Dim NewTblRow As ListRow
                
            If Worksheets("AFRsInput").Range("D4").Value = vbNullString Then
                Worksheets("AFRsInput").Range("D4:D19").ClearContents
                Worksheets("AFRsInput").Range("H4:H18").ClearContents
                Worksheets("AFRsInput").Range("H19").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L4").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L7").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L10").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L13").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L19").MergeArea.ClearContents
                Worksheets("AFRsInput").Range("L23").ClearContents
                    On Error Resume Next
                    wsTar.ListObjects("Table1").DataBodyRange.Delete
                    On Error GoTo 0
                    GoTo end_the_sub:
            End If
                
            Set rng = wsSrc1.Range("C:C").Find(lngAFR, , xlValues, xlWhole)
                If Not rng Is Nothing Then
                    lngRow = rng.Row
                    For i = 3 To 41
                        Set rng2 = wsTar.Range("B4:J23").Find(wsSrc1.Cells(1, i).Value)
                        rng2.Offset(0, 2) = wsSrc1.Cells(lngRow, i)
                    Next i
                            
                On Error Resume Next
                wsTar.ListObjects("Table1").DataBodyRange.Delete
                On Error GoTo 0
                With wsSrc2
                    lngSrc2LR = .Cells(Rows.Count, "A").End(xlUp).Row
                    For i = 3 To lngSrc2LR
                        If .Cells(i, "C") = lngAFR Then
                            Set NewTblRow = wsTar.ListObjects("Table1").ListRows.Add
                            'NewTblRow.Range(1) = .Cells(i, "C")
                            NewTblRow.Range(1) = .Cells(i, "D")
                            NewTblRow.Range(2) = .Cells(i, "E")
                            NewTblRow.Range(3) = .Cells(i, "F")
                        End If
                    Next i
                        On Error Resume Next
                        wsTar.ListObjects("Table1").DataBodyRange.Locked = False
                        On Error GoTo 0
                End With
            Else
                myAnswer = MsgBox("Are you sure you want to add this new AFR#?", vbYesNo)
                If myAnswer <> vbYes Then Exit Sub
                myPassRequest = InputBox("Please enter the password to verify the new AFR#")
                If myPassRequest <> myPass Then
                    MsgBox ("Sorry, that password is incorrect")
                    Worksheets("AFRsInput").Range("D4").Value = vbNullString
                    GoTo end_the_sub:
                Else
                    MsgBox ("New AFR# accepted.")
                    
                    With ThisWorkbook.Sheets("AFRsInput")
                        .Range("D5:D19,H4:H18").ClearContents
                        .Cells(19, "H").MergeArea.ClearContents
                        .Cells(4, "L").MergeArea.ClearContents
                        .Cells(7, "L").MergeArea.ClearContents
                        .Cells(10, "L").MergeArea.ClearContents
                        .Cells(13, "L").MergeArea.ClearContents
                        .Cells(19, "L").MergeArea.ClearContents
                        .Range("L23").ClearContents
                    On Error Resume Next
                        .ListObjects("Table1").DataBodyRange.Delete
                    On Error GoTo 0
                    End With
                     Range("L23") = "Open"
                    End If
                End If
            End With
end_the_sub:
        wsTar.Protect "pass"
        Range("D4").Select
       
        End Sub

 

[Legacy 436357]

Never mind I figured it out. Thanks anyway