Sub CreateSheet()

    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "WYNIK" Then
            MsgBox "WYNIK sheet exists! Please, remove it.", vbCritical, "Error"
            End
        End If
    Next i

    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WYNIK"
    End With

End Sub

Sub DeleteSheet()

Application.DisplayAlerts = False
Worksheets("WYNIK").Delete
Application.DisplayAlerts = True

End Sub


Sub questions_to_new_sheet()

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
Dim SearchRange As Range
Dim FindCell As Range
Dim ColTitle As String


Set wbCurrent = ActiveWorkbook
Set ws = wbCurrent.ActiveSheet
Set ChoiceColumn = ws.Range("A1:Z1").Find("WYBÓR")
ColTitle = Replace(ChoiceColumn.Address(True, False), "$1", "")

With ws
      LastRow = .Cells(.Rows.Count, ChoiceColumn.Column).End(xlUp).Row
End With

Set SearchRange = Range(ColTitle + "1:" + ColTitle & LastRow)
Call CreateSheet
Set ws2 = wbCurrent.Worksheets("WYNIK")



For Each FindCell In SearchRange
    If (FindCell.Value = "X") Or (FindCell.Value = "x") Then
        FindCounter = FindCounter + 1
        If FindCounter = 1 Then
            ws2.Range("A1").Value = "PYTANIE"
        End If
        FindCell.Offset(0, 1).Resize(, 1).Copy
        ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    End If
Next

If FindCounter = 0 Then
Call DeleteSheet
MsgBox "No questions found to copy", vbCritical, "Error"
End
End If

ws2.Range("A1").EntireColumn.AutoFit

MsgBox FindCounter & " questions have been copied", vbOKOnly, "Succes"
Application.ScreenUpdating = True

End Sub