Új hozzászólás Aktív témák

• #42231 Pakliman tag huan #42209

  Új Válasz 2019-11-19 08:07:14 #42231

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz huan #42209 üzenetére

  Szia!

  (Egyféle) megoldás kis kiegészítéssel és makróval:
  
  (Ez a kép már a makró általi lista, a színezés az eredeti)
  Minden csoport ki lett egészítve egy új oszloppal, ami azért kell, mert egy tétel többször is szerepelhet és valahogy muszáj megkülönböztetni
  P oszlopban: =DARABTELI($O$2:O2;O2)
  S oszlopban: =DARABTELI($R$2:R2;R2)
  V oszlopban: =DARABTELI($U$2:U2;U2)
  FONTOS!!!! Figyelj a dollárjelre!!!!
  (Beírod pl. a P2 cellába és "lehúzod" P16-ig)

  A kód:

  Public Sub Rendez()
Dim o As Long
Dim s0 As Long
Dim s As Long
Dim us As Long
Dim us2 As Long
Dim bVan As Boolean

For o = 14 To 20 Step 3
us = Columns(o).Rows(Rows.Count).End(xlUp).Row
For s = 2 To us
If o = 14 Then
'1. oszlopcsoport, csak másolunk...
Cells(s, o - 12) = Cells(s, o)
Cells(s, o - 11) = Cells(s, o + 1)
Cells(s, o - 10) = Cells(s, o + 2)
Else
us2 = Columns(o - 15).Rows(Rows.Count).End(xlUp).Row
For s0 = 2 To us2
bVan = (Cells(s0, o - 15) = Cells(s, o)) And (Cells(s0, o - 14) = Cells(s, o + 1)) And (Cells(s0, o - 13) = Cells(s, o + 2))
If bVan Then Exit For
Next s0

If bVan Then
us2 = s0
Else
us2 = Application.Max(Columns(o - 12).Rows(Rows.Count).End(xlUp).Row, Columns(o - 15).Rows(Rows.Count).End(xlUp).Row) + 1
End If
Cells(us2, o - 12) = Cells(s, o)
Cells(us2, o - 11) = Cells(s, o + 1)
Cells(us2, o - 10) = Cells(s, o + 2)
End If
Next s
Next o
End Sub

Új hozzászólás Aktív témák