Dim i As Integer, j As Integer, k As Integer, iMax As Integer
    Dim strVal As String
    
    iMax = Sheets(1).[D65536].End(xlUp).Row

    'ReDim Preserve arr(iTag)
    With Sheets(1)

        For i = iRow To iMax
            Dim Arr As Variant
            Dim strR As String
            Dim iTag As Integer 
            strR = ""
            ReDim Arr(0)
            iTag = 0
            k = 0
            While Len(strR) < 98
                ReDim Preserve Arr(iTag)

                For j = 1 To 6
                    strVal = Right("0" & .Cells(i - k, 3 + j), 2)

                    If InStr(strR, strVal) < 1 Then
                        If strR <> "" Then
                            strR = strR & ","
                        End If

                        strR = strR & strVal

                        If Arr(iTag) <> "" Then
                            Arr(iTag) = Arr(iTag) & ","
                        End If

                        Arr(iTag) = Arr(iTag) & strVal
                    End If

                Next

                If Arr(iTag) <> "" Then
                    iTag = iTag + 1
                End If

                k = k + 1
            Wend
            'Debug.Print UBound(arr)
            Call Donner_Init(Arr, i + 1)
           
ReDim Preserve arr(0)
        Next

    End With