Macro gefilterde kolom kopieren naar volgend tabblad met extras

Sub DoIt()
    Dim xlWsOut As Worksheet
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim aData, aDataOut, vKey
    Dim id
    Dim i As Long, j As Long, nrCount As Long
    
    Application.ScreenUpdating = False
    
    Set xlWsOut = ThisWorkbook.Worksheets(2)
    
    aData = Application.WorksheetFunction.Transpose(ActiveSheet.UsedRange.Value2)

    For i = LBound(aData, 1) To UBound(aData, 1)
        If Not IsEmpty(aData(i, 2)) Then
            If Not IsEmpty(aData(i, 1)) Then
                id = aData(i, 1)
            End If
            For j = 2 To UBound(aData, 2)
                If IsNumeric(aData(i, j)) And aData(i, j) > 0 Then
                    nrCount = nrCount + 1
                    dic.Item(nrCount) = Array(nrCount, id, aData(i, j))
                End If
            Next j
        End If
    Next i
    
    ReDim aDataOut(1 To dic.Count, 1 To 3)
    i = 1
    For Each vKey In dic.Keys
        For j = 0 To 2
            aDataOut(i, j + 1) = dic.Item(vKey)(j)
        Next j
        i = i + 1
    Next vKey
    
    With xlWsOut
        .Range("A1:C1").Value2 = Array("NR", "ID", "T en C")
        .Range(.Cells(2, 1), .Cells(UBound(aDataOut, 1) + 1, 3)).Value2 = aDataOut
    End With
    
    xlWsOut.Activate
    
    MsgBox "Done.", vbInformation + vbOKOnly, "Done."
    
    Application.ScreenUpdating = True
    
End Sub[CODE]