Страницы: 1
RSS
Групповое транспонирование, Оптимизировать код VBA
 
 Ради спортивного интереса  ,   кто нибудь сможет ,  или вообще возможно ли что  то красивей наколякать
Код
Sub Кнопка1_Щелчок()
  
   k1 = 0
   k2 = 0
   k3 = 0
   k4 = 0

  For i = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Step 1
   z1 = Cells(i, 1).Value
   z2 = Cells(i + 1, 1).Value
   z3 = Cells(i + 2, 1).Value
   z4 = Cells(i + 3, 1).Value
   
   k1 = Cells(i, 5).Value
   k2 = Cells(i + 1, 5).Value
   k3 = Cells(i + 2, 5).Value
   k4 = Cells(i + 3, 5).Value
   
   If z1 = z2 And z1 = z3 And z1 = z4 And k4 = 4 Then '----------------------------- 1-2-3-4
      Cells(i, 6).Value = Cells(i, 2).Value
      Cells(i, 7).Value = Cells(i, 3).Value
      Cells(i, 8).Value = Cells(i, 4).Value
      
      Cells(i, 9).Value = Cells(i + 1, 2).Value
      Cells(i, 10).Value = Cells(i + 1, 3).Value
      Cells(i, 11).Value = Cells(i + 1, 4).Value
      
      Cells(i, 12).Value = Cells(i + 2, 2).Value
      Cells(i, 13).Value = Cells(i + 2, 3).Value
      Cells(i, 14).Value = Cells(i + 2, 4).Value
      
      Cells(i, 15).Value = Cells(i + 3, 2).Value
      Cells(i, 16).Value = Cells(i + 3, 3).Value
      Cells(i, 17).Value = Cells(i + 3, 4).Value
      i = i + 3
   End If '----------------------------------------------------------------------------------
    
   If z1 = z2 And z1 = z3 And Not (z1 = z4) And k1 = 1 And k2 = 2 And k3 = 3 Then '-----1-2-3
      Cells(i, 6).Value = Cells(i, 2).Value
      Cells(i, 7).Value = Cells(i, 3).Value
      Cells(i, 8).Value = Cells(i, 4).Value
      
      Cells(i, 9).Value = Cells(i + 1, 2).Value
      Cells(i, 10).Value = Cells(i + 1, 3).Value
      Cells(i, 11).Value = Cells(i + 1, 4).Value
      
      Cells(i, 12).Value = Cells(i + 2, 2).Value
      Cells(i, 13).Value = Cells(i + 2, 3).Value
      Cells(i, 14).Value = Cells(i + 2, 4).Value
      i = i + 2
   End If '---------------------------------------------------------------------------------
    
   If z1 = z2 And z1 = z3 And Not (z1 = z4) And k1 = 2 And k2 = 3 And k3 = 4 Then '--- 2-3-4
      Cells(i, 9).Value = Cells(i, 2).Value
      Cells(i, 10).Value = Cells(i, 3).Value
      Cells(i, 11).Value = Cells(i, 4).Value
      
      Cells(i, 12).Value = Cells(i + 1, 2).Value
      Cells(i, 13).Value = Cells(i + 1, 3).Value
      Cells(i, 14).Value = Cells(i + 1, 4).Value
      
      Cells(i, 15).Value = Cells(i + 2, 2).Value
      Cells(i, 16).Value = Cells(i + 2, 3).Value
      Cells(i, 17).Value = Cells(i + 2, 4).Value
      i = i + 2
   End If '-------------------------------------------------------------------------------
    
   If z1 = z2 And Not (z1 = z3) And Not (z1 = z4) And k1 = 1 And k2 = 2 Then ' ------- 1-2
      Cells(i, 6).Value = Cells(i, 2).Value
      Cells(i, 7).Value = Cells(i, 3).Value
      Cells(i, 8).Value = Cells(i, 4).Value
      
      Cells(i, 9).Value = Cells(i + 1, 2).Value
      Cells(i, 10).Value = Cells(i + 1, 3).Value
      Cells(i, 11).Value = Cells(i + 1, 4).Value
      i = i + 1
   End If '-------------------------------------------------------------------------------
    
   If z1 = z2 And Not (z1 = z3) And Not (z1 = z4) And k1 = 2 And k2 = 3 Then ' ------- 2-3
      Cells(i, 9).Value = Cells(i, 2).Value
      Cells(i, 10).Value = Cells(i, 3).Value
      Cells(i, 11).Value = Cells(i, 4).Value
      
      Cells(i, 12).Value = Cells(i + 1, 2).Value
      Cells(i, 13).Value = Cells(i + 1, 3).Value
      Cells(i, 14).Value = Cells(i + 1, 4).Value
      i = i + 1
   End If '-------------------------------------------------------------------------------
    
   If z1 = z2 And Not (z1 = z3) And Not (z1 = z4) And k1 = 3 And k2 = 4 Then ' ------ 3-4
      Cells(i, 12).Value = Cells(i, 2).Value
      Cells(i, 13).Value = Cells(i, 3).Value
      Cells(i, 14).Value = Cells(i, 4).Value
      
      Cells(i, 15).Value = Cells(i + 1, 2).Value
      Cells(i, 16).Value = Cells(i + 1, 3).Value
      Cells(i, 17).Value = Cells(i + 1, 4).Value
      i = i + 1
   End If '------------------------------------------------------------------------------
    
   If Not (z1 = z2) And Not (z1 = z3) And Not (z1 = z4) And k1 = 1 Then ' ------------- 1
      Cells(i, 6).Value = Cells(i, 2).Value
      Cells(i, 7).Value = Cells(i, 3).Value
      Cells(i, 8).Value = Cells(i, 4).Value
   End If
   If Not (z1 = z2) And Not (z1 = z3) And Not (z1 = z4) And k1 = 2 Then '--------------  2
      Cells(i, 9).Value = Cells(i, 2).Value
      Cells(i, 10).Value = Cells(i, 3).Value
      Cells(i, 11).Value = Cells(i, 4).Value
   End If
   If Not (z1 = z2) And Not (z1 = z3) And Not (z1 = z4) And k1 = 3 Then '-------------   3
      Cells(i, 12).Value = Cells(i, 2).Value
      Cells(i, 13).Value = Cells(i, 3).Value
      Cells(i, 14).Value = Cells(i, 4).Value
   End If
   If Not (z1 = z2) And Not (z1 = z3) And Not (z1 = z4) And k1 = 4 Then '--------------  4
      Cells(i, 15).Value = Cells(i, 2).Value
      Cells(i, 16).Value = Cells(i, 3).Value
      Cells(i, 17).Value = Cells(i, 4).Value
   End If
   
   z1 = 0
   z2 = 0
   z3 = 0
   z4 = 0
    
   k1 = 0
   k2 = 0
   k3 = 0
   k4 = 0
   
  Next i
  
End Sub
 
Сам файл
 
Кросс
 
gling, спасибо.
Я сам - дурнее всякого примера! ...
 
Цитата
vova-vba написал: Ради спортивного интереса
Именно исходя из него сделал на массивах и словаре. 32 строки кода. Если интересно - устраните в теме нарушения Правил форума
Согласие есть продукт при полном непротивлении сторон
 
Не чего не понял из вашего поста,  какие нарушения, и что устранить,   исходя из чего на массивах,

gling,   большое спасибо ,  не код а просто песня ,   выразить не могу
 
Цитата
vova-vba написал: исходя из чего
Из 'спортивного интереса'

Цитата
vova-vba написал: какие нарушения
Нарушения Правил форума в теме. В частности про то, что Вы еще где-то разместили такой-же вопрос
За помощь в темах с нарушением модераторы наказывают как спрашивающих, так и помогающих

Цитата
vova-vba написал: на массивах
Есть такое понятие в VBA

Так что если Вам интересно, приведите ссылки на ресурсы, где еще Вам помогают по этому вопросу
Согласие есть продукт при полном непротивлении сторон
 
gling, что-бы сетку таблицы не перерисовывать можно
Код
Range("F2:Q" & lLastRow).ClearContents
а
Код
Range("F2:Q" & lLastRow).Borders.LineStyle = xlContinuous
удалить
Еще на одну строку короче  :)
Согласие есть продукт при полном непротивлении сторон
 
Надеюсь все поняли, кому помогали?
Я сам - дурнее всякого примера! ...
 
Sanja, при .ClearContents останется и заливка ячеек вместе с сеткой, а это не желательно. Имхо.
Цитата
Еще на одну строку короче
Тогда пришлось бы дописать строку с удалением заливки ячеек.
Знал бы,  что vova-vba такой человек, не помогал бы.
Изменено: gling - 19.02.2017 11:58:45
 
vova-vba, выписал Вам бан за оскорбление.  
Страницы: 1
Наверх