Как кодировать каждый результат в столбце, чтобы вставить текст - PullRequest
0 голосов
/ 10 января 2019

Цель: У меня есть ряд результатов, появляющихся в следующей пустой строке для столбцов A, B и D (скриншот ниже). Для столбца C я хотел бы создать функцию, которая для каждого результата в столбце A говорит (из моего кода), что столбец C просто вставляет «Прерывание работы».

enter image description here

Мой текущий код выглядит следующим образом :

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

Я понимаю, что мой код громоздкий, но я не знаю, как его упростить, поэтому оставляю его как есть. Может ли кто-нибудь помочь? Спасибо.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...