Макрос для объединения ячеек на основании данных других столбцов

Option Explicit
 
Sub Проба_v1()
    Dim lastRow As Long, col As Long, i As Long
    Dim rCell As Range, cell As Range
 
    Dim wsSource    As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Форма для заполнения")
 
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
 
        With ThisWorkbook.Worksheets("база оценки рисков")
 
            Dim copyRanges As Variant, targetCols As Variant
            copyRanges = Array("C5", "D5", "F5", "C8", "F8", "C13", "F13", "C16", "B28", "D28", "F28", "C34:C46", "D34:D46", "B50", "D50", "F50", "B58", "D58", "F58")
            targetCols = Array(3, 4, 27, 5, 6, 7, 8, 9, 10, 12, 14, 18, 19, 20, 22, 24, 30, 32, 34)
 
            Dim textQ As String
            textQ = ""
 
            For Each cell In wsSource.Range("F16:F24")
 
                If cell.Value <> "" Then
                    textQ = textQ & cell.Value & vbCrLf
                End If
 
            Next cell
 
            If Len(textQ) > 0 Then
                textQ = Left(textQ, Len(textQ) - Len(vbCrLf))
            End If
 
            '            Debug.Print textQ
 
            Dim rng As Range
            Set rng = wsSource.Range("C34:C46")
 
            Dim rowCount As Long
            rowCount = Application.WorksheetFunction.CountA(rng)
            If rowCount = 0 Then Exit Sub
 
            Dim Mergecell As Range
            Set Mergecell = .Range("C7:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
 
            Dim iMergecell As Boolean
            iMergecell = False
 
            For Each cell In Mergecell
 
                If cell.MergeCells Then
                    iMergecell = True
                    Exit For
                End If
 
            Next cell
 
            For i = LBound(copyRanges) To UBound(copyRanges)
                wsSource.Range(copyRanges(i)).Copy
 
                If iMergecell Then
                    Dim resultCell As Range
 
                    lastRow = .Cells(.Rows.Count, targetCols(i)).End(xlUp).Row
                    Set cell = .Cells(lastRow, targetCols(i))
 
                    If cell.MergeCells Then
                        Set resultCell = cell.MergeArea.Cells(cell.MergeArea.Cells.Count)
                    Else
                        Set resultCell = cell
                    End If
 
                    lastRow = resultCell.Row + 1
                Else
                    lastRow = .Cells(.Rows.Count, targetCols(i)).End(xlUp).Row + 1
                End If
 
                If iMergecell And i = 12 Or i = 13 Then
                    lastRow = lastRow
                End If
 
                .Cells(lastRow, targetCols(i)).PasteSpecial Paste:=xlPasteValues
                '        Debug.Print "target Column is: " & targetCols(i)
            Next i
 
            If Application.WorksheetFunction.CountA(rng) > 1 Then
                '                Debug.Print "В диапазоне больше одного значения"
 
                Dim insertRow As Long
                insertRow = .Cells(.Rows.Count, "T").End(xlUp).Row
                '                Debug.Print insertRow
 
                .Range(.Cells(insertRow, 2), .Cells(insertRow + rowCount - 2, 16)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                .Range(.Cells(insertRow, 20), .Cells(insertRow + rowCount - 2, 36)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
                For col = 2 To 16
                    '                    Debug.Print "target Column is: " & Cells(1, col).Address
 
                    With .Range(.Cells(insertRow, col), .Cells(insertRow + rowCount - 1, col))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
 
                Next col
 
                For col = 17 To 17
 
                    With .Range(.Cells(insertRow, col), .Cells(insertRow + rowCount - 1, col))
                        .Merge
                        .Value = textQ
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
 
                Next col
 
                For col = 20 To 36
 
                    With .Range(.Cells(insertRow, col), .Cells(insertRow + rowCount - 1, col))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
 
                Next col
 
            Else
                '                Debug.Print "В диапазоне одно или нет значений"
 
                For col = 17 To 17
                    insertRow = .Cells(.Rows.Count, "R").End(xlUp).Row
                    '                    Debug.Print insertRow
 
                    With .Range(.Cells(insertRow, col), .Cells(insertRow + rowCount - 1, col))
                        '                        Debug.Print "insert Row is: " & insertRow
 
                        .Value = textQ
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
 
                Next col
            End If
 
            Set rng = Nothing
        End With
 
        Set wsSource = Nothing
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
 
End Sub