Sub Macro() ' ' Macro Macro ' ' Keyboard Shortcut: Option+Cmd+r ' 'START collect and enter questions Set sht = ThisWorkbook.Worksheets("Bayer") LastColumn = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column a = (LastColumn - 5) / 3 Debug.Print a

    Dim keyWord()
    keyWord = Array("Yes, I agree", "Well, I'm not sure", "No, I disagree")
    Debug.Print UBound(keyWord)
    b = UBound(keyWord)

    For i = 0 To (a - 1) Step 1
    Sheets("Bayer").Select
    Cells(1, i * 3 + 6).Select
    Selection.Copy
    Sheets("survey-name_results-from").Select
    Cells(9 + i, 2).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ExecuteExcel4Macro "ALIGNMENT(1,TRUE,1,FALSE,FALSE,,FALSE,FALSE,0,1)"
    With Selection.Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.RowHeight = 75

    Sheets("survey-name_results-from").Select
    Cells(9 + i, 1).Select
    ActiveCell.FormulaR1C1 = "N-" & i + 1
    Cells(9 + i, 1).Select
    ExecuteExcel4Macro "ALIGNMENT(3,FALSE,2,FALSE,FALSE,,FALSE,FALSE,0,1)"
    With Selection.Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    'Count "answers"

    For j = 0 To UBound(keyWord) Step 1

    Sheets("survey-name_results-from").Select

    Cells(9 + i, j + 3).Formula = "=countif(Bayer!" & Range(Cells(2, i * 3 + 6), Cells(4, i * 3 + 6)).Address(False, False) & "," & """*" & keyWord(j) & "*" & """)"

    ExecuteExcel4Macro "ALIGNMENT(3,FALSE,2,FALSE,FALSE,,FALSE,FALSE,0,1)"
    With Selection.Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 12
        .StrikeThrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous & ""
        .Weight = xlThin
        .ColorIndex = 1
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    Next j
    'End Count "answers"

    'count "No I disagree"
    'Cells(9 + i, UBound(keyWord) + 4).Formula = "=" & UBound(keyWord) + 1 & "-SUM" & Range(Cells(9 + i, 3), Cells (9 + i, UBound(keyWord) + 3 ).Address(False,False)

    Cells(9 + i, UBound(keyWord) + 4).Formula = "=" & UBound(keyWord) + 1 & "-SUM(" & Range(Cells(9 + i, 3).Address, Cells(9 + i, UBound(keyWord) + 3).Address(False, False) & ")"


    Next i

    'END collect and enter questions

    End Sub