[URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47  48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63  64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79  80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95  96  97  98  99  100  101  102  103  104  105  106  107  108  109  110  111  112  113  114  115  116  117  118  119  120  121  122  123  124  125  126  127  128  129  130  131  132  133  134  135  136  137  138  139  140  141  142  143  144  145  146  147  148  149  150  151  152  153  154  155  156  157  158  159  160  161  162  163  164  165  166  167  168  169  170  171      Option   Explicit       Private   Const   GROUP_SIZE = 5       Sub   MakeZTable()          CloseEmptyWb          Dim   zayvki   As   Variant          zayvki = Sheets(  "ЗАЯВКИ"  ).ListObjects(  "ЗАЯВКИ"  ).Range.Value          ReplaceZero zayvki, 6                   Dim   wb   As   Workbook          Dim   sh   As   Worksheet          Dim   rr   As   Range          Set   wb = Workbooks.Add(1)          Set   sh = wb.Sheets(1)          Set   rr = sh.Cells(1, 1).Resize(UBound(zayvki, 1), UBound(zayvki, 2))                   rr.Value = zayvki          SortRange rr          zayvki = rr.Value          'rr.EntireColumn.AutoFit                   Dim   aCategory   As   Variant          aCategory = SplitCategory(rr)          rr.Clear                   Dim   aGroups   As   Variant          aGroups = SplitGroups(aCategory)                   Dim   outputArray   As   Variant          outputArray = GetOutputArray(aGroups)                   Set   rr = sh.Cells(6, 2).Resize(UBound(outputArray, 1), UBound(outputArray, 2))          rr.Value = outputArray          rr.EntireColumn.AutoFit    End   Sub       Private   Function   GetOutputArray(aGroups   As   Variant  )   As   Variant          Dim   arr   As   Variant          ReDim   arr(1   To   (GROUP_SIZE + 2) * UBound(aGroups), 1   To   8)                   Dim   yy   As   Long          Dim   yg   As   Long          Dim   iGroup   As   Long          Dim   vGroup   As   Variant          For   iGroup = 1   To   UBound(aGroups)              vGroup = aGroups(iGroup)              yy = yy + 1              arr(yy, 2) =   "Заплыв №"   & iGroup              For   yg = 1   To   UBound(vGroup, 1)                  yy = yy + 1                  arr(yy, 1) =   "дорожка № "   & yg                  arr(yy, 2) = vGroup(yg, 1)                  arr(yy, 3) =   "Заплыв №"   & iGroup                  arr(yy, 4) = vGroup(yg, 2)                  arr(yy, 5) = vGroup(yg, 3)                  arr(yy, 6) = vGroup(yg, 4)              Next              For   yg = UBound(vGroup, 1) + 1   To   GROUP_SIZE                  yy = yy + 1              Next              yy = yy + 1          Next                   GetOutputArray = arr    End   Function       Private   Function   SplitGroups(aCategory   As   Variant  )   As   Variant          Dim   vCategory   As   Variant          Dim   nGroup   As   Long          Dim   y1   As   Long          Dim   y2   As   Long          Dim   arr   As   Variant          Dim   brr   As   Variant          ReDim   arr(0   To   0)          For   Each   vCategory   In   aCategory              If   Not   IsEmpty(vCategory)   Then                  nGroup = WorksheetFunction.RoundUp(UBound(vCategory, 1) / GROUP_SIZE, 0)                  y1 = 1                  Do                      If   nGroup <= 0   Then   Exit   Do                      If   y1 > UBound(vCategory, 1)   Then   Exit   Do                      y2 = UBound(vCategory, 1) - y1 + 1                      If   nGroup > 1   Then   y2 = WorksheetFunction.Round(y2 / nGroup, 0)                      y2 = y1 + y2 - 1                      brr = GetSubRowsArray(vCategory, y1, y2)                                           ReDim   Preserve   arr(0   To   UBound(arr) + 1)                      arr(UBound(arr)) = brr                      Erase   brr                      y1 = y2 + 1                      nGroup = nGroup - 1                  Loop              End   If          Next          SplitGroups = arr    End   Function       Private   Function   GetSubRowsArray(arr   As   Variant  , y1   As   Long  , y2   As   Long  )   As   Variant          Dim   brr   As   Variant          ReDim   brr(1   To   y2 - y1 + 1, 1   To   UBound(arr, 2))          Dim   yy   As   Long          Dim   xx   As   Long          For   yy = 1   To   UBound(brr, 1)              For   xx = 1   To   UBound(brr, 2)                  brr(yy, xx) = arr(y1 + yy - 1, xx)              Next          Next          GetSubRowsArray = brr    End   Function       Private   Function   SplitCategory(rr   As   Range)   As   Variant          Dim   arr   As   Variant          Dim   brr   As   Variant          Dim   crr   As   Variant          ReDim   crr(0   To   0)          arr = rr.Value                   Dim   y1   As   Long          Dim   y2   As   Long          With   rr              For   y1 = 2   To   UBound(arr, 1)                  If   Not   IsEmpty(arr(y1, 1))   Then                      For   y2 = y1 + 1   To   UBound(arr, 1)                          If   arr(y2, 5) <> arr(y1, 5)   Then   Exit   For                          If   arr(y2, 3) <> arr(y1, 3)   Then   Exit   For                      Next                      y2 = y2 - 1                      brr = .Range(.Cells(y1, 1), .Cells(y2, UBound(arr, 2))).Value                      ReDim   Preserve   crr(0   To   UBound(crr) + 1)                      crr(UBound(crr)) = brr                      Erase   brr                                           y1 = y2                  End   If              Next          End   With          SplitCategory = crr    End   Function       Private   Sub   SortRange(rr   As   Range)          Dim   sh   As   Worksheet          Set   sh = rr.Parent          With   sh.Sort              .SortFields.Clear              .SortFields.Add Key:=rr.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal              .SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal              .SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal              .SetRange rr              .Header = xlYes              .MatchCase =   False              .Orientation = xlTopToBottom              .SortMethod = xlPinYin              .Apply          End   With       End   Sub       Private   Sub   ReplaceZero(arr   As   Variant  , xx   As   Long  )          Dim   yy   As   Long          For   yy = 2   To   UBound(arr, 1)              If   arr(yy, xx) =   "-"   Then   arr(yy, xx) = Empty          Next    End   Sub       Sub   CloseEmptyWb(  Optional   flag   As   Boolean  )          Dim   wb   As   Workbook          For   Each   wb   In   Application.Workbooks              If   wb.Path =   ""   Then   wb.Close   False          Next    End   Sub