Sub perenos()
Dim iz As Worksheet
Dim v As Worksheet
Set iz = Worksheets(1)
Set v = Worksheets(2)
Dim i&, j As Long
Dim rez, ar, dic, nm
With iz.Range("A1").CurrentRegion
    col = .Columns.Count
    r = .Rows.Count
End With
With v.Range("A1").CurrentRegion
    col2 = .Columns.Count
    r2 = .Rows.Count
End With
ar = iz.Cells(1).Resize(, col)
tov = WorksheetFunction.Match("Товар", ar, 0)
tt = WorksheetFunction.Match("ТТ", ar, 0)
ned = WorksheetFunction.Match("неделя", ar, 0)
prig = WorksheetFunction.Match("пригодность", ar, 0)
ar = iz.Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
On Error Resume Next
For i = 2 To r
 If ar(i, prig) > 0 Then
    dic.Add ar(i, tt), dic.Count + 1
    If nm < ar(i, ned) Then nm = ar(i, ned)
End If
Next i
ReDim rez(1 To dic.Count, 1 To nm + 1)
For i = 2 To r
    If ar(i, prig) > 0 Then
        j = dic(ar(i, tt))
        If rez(j, ar(i, ned) + 1) = Empty Then
            rez(j, ar(i, ned) + 1) = "'" & ar(i, tov)
            rez(j, 1) = ar(i, tt)
        Else
            rez(j, ar(i, ned) + 1) = rez(j, ar(i, ned) + 1) & "," & ar(i, tov)
        End If
    End If
Next i
Set dic = Nothing
v.Cells(3, 1).Resize(UBound(rez), UBound(rez, 2)) = rez
End Sub