How to code for each result in column to paste text

Question

Goal: I have a set of results appearing at the next empty row for columns A, B and D (below screenshot). For Column C, I would like to build a function that would, for each result in column say A (from my code), Column C would simply paste "Business Interruption".

My Current code looks as below:

Sub Calc_Parish()

'Calculates the Parish for AICOW

Dim RPDataTbl As ListObject
    Dim parishCol As ListColumn, AICOWcol As ListColumn
    Dim copyRng As Range

    Set RPDataTbl = Sheets("Risk Partner Data").ListObjects("RPdata")
    With RPDataTbl
        Set parishCol = .ListColumns("Parish & Code")
        Set AICOWcol = .ListColumns("AICOW")

        .Range.AutoFilter Field:=AICOWcol.Index, Criteria1:="TRUE"
    End With

    On Error Resume Next
    Set copyRng = parishCol.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not copyRng Is Nothing Then
        copyRng.Copy

        With Sheets("Calc Data")
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With

        Application.CutCopyMode = False
    End If

    RPDataTbl.Range.AutoFilter Field:=AICOWcol.Index

End Sub

Sub Calc_Buildno()

' Calculates the Build # for AICOW

Dim RPDataTbl As ListObject
    Dim BuildnoCol As ListColumn, AICOWcol As ListColumn
    Dim copyRng As Range

    Set RPDataTbl = Sheets("Risk Partner Data").ListObjects("RPdata")
    With RPDataTbl
        Set BuildnoCol = .ListColumns("Building ID 1")
        Set AICOWcol = .ListColumns("AICOW")

        .Range.AutoFilter Field:=AICOWcol.Index, Criteria1:="TRUE"
    End With

    On Error Resume Next
    Set copyRng = BuildnoCol.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not copyRng Is Nothing Then
        copyRng.Copy

        With Sheets("Calc Data")
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With

        Application.CutCopyMode = False
    End If

    RPDataTbl.Range.AutoFilter Field:=AICOWcol.Index

' Need to add here the Insured Asset (Column C) as Business Interruption

End Sub

Sub Calc_Cresta()

' Calculates Cresta for AICOW

Dim RPDataTbl As ListObject
    Dim CrestaCol As ListColumn, AICOW As ListColumn
    Dim copyRng As Range

    Set RPDataTbl = Sheets("Risk Partner Data").ListObjects("RPdata")
    With RPDataTbl
        Set CrestaCol = .ListColumns("Cresta")
        Set AICOWcol = .ListColumns("AICOW")

        .Range.AutoFilter Field:=AICOWcol.Index, Criteria1:="TRUE"
    End With

    On Error Resume Next
    Set copyRng = CrestaCol.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not copyRng Is Nothing Then
        copyRng.Copy

        With Sheets("Calc Data")
            .Cells(.Rows.Count, "D").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With

        Application.CutCopyMode = False
    End If

    RPDataTbl.Range.AutoFilter Field:=AICOWcol.Index

End Sub

I understand my code is bulky, but I dont know how to simplify it, so leaving it as is. Could someone please assist? Thank you.