Option Base 1

Sub newera()

a = Timer

Dim Array_Str(1 To 8) As String, Array_2(1 To 7) As String, y As Integer, j As Long, o As Integer, p As Integer, q As Integer, Destination As Range

MinPos = Cells(4, 8)
MaxPos = Cells(4, 9)
MinNeu = Cells(5, 8)
MaxNeu = Cells(5, 9)
MinNeg = Cells(6, 8)
MaxNeg = Cells(6, 9)

For j = 28 To Cells(Rows.Count, 1).End(xlUp).Row

For y = 28 To Cells(Rows.Count, 10).End(xlUp).Row

o = (WorksheetFunction.CountIf(Range(Cells(j, 1), Cells(j, 8)), "positive") + WorksheetFunction.CountIf(Range(Cells(y, 10), Cells(y, 16)), "positive"))
p = (WorksheetFunction.CountIf(Range(Cells(j, 1), Cells(j, 8)), "neutral") + WorksheetFunction.CountIf(Range(Cells(y, 10), Cells(y, 16)), "neutral"))
q = (WorksheetFunction.CountIf(Range(Cells(j, 1), Cells(j, 8)), "negative") + WorksheetFunction.CountIf(Range(Cells(y, 10), Cells(y, 16)), "negative"))


If o >= MinPos And o <= MaxPos And p >= MinNeu And p <= MaxNeu And q >= MinNeg And q <= MaxNeg Then

Array_Str(1) = Cells(j, 1)
Array_Str(2) = Cells(j, 2)
Array_Str(3) = Cells(j, 3)
Array_Str(4) = Cells(j, 4)
Array_Str(5) = Cells(j, 5)
Array_Str(6) = Cells(j, 6)
Array_Str(7) = Cells(j, 7)
Array_Str(8) = Cells(j, 8)

Array_2(1) = Cells(y, 10)
Array_2(2) = Cells(y, 11)
Array_2(3) = Cells(y, 12)
Array_2(4) = Cells(y, 13)
Array_2(5) = Cells(y, 14)
Array_2(6) = Cells(y, 15)
Array_2(7) = Cells(y, 16)

I = Cells(Rows.Count, 20).End(xlUp).Row + 1

Set Destination = Range(Cells(I, 20), Cells(I, 20))

Set Destination = Destination.Resize(1, UBound(Array_Str))

Destination.Value = Array_Str

Set Destination = Range(Cells(I, 28), Cells(I, 28))

Set Destination = Destination.Resize(1, UBound(Array_2))

Destination.Value = Array_2

Else

End If

Next y

Next j

MsgBox Timer - a

End Sub