Excel- makro na vyhledání a přesunutí

[Hawkey]

tady je ukazka jak to ma byt finalne

[Reklama]

[navstevnik]

Uvadis v popisu cinnosti: "Takto se spojí za podmínky, že sloupce A,B,E a F jsou stejné", pro shodne B, E, F je vsak hodnota v A rozdilna.
Nize uvedena procedura tedy vykona pozadovane mimo shodu v A za predpokladu, ze sheet1 je setriden jak uvadis:

Kód: Vybrat vše

Option Explicit

Sub FindTransfer()
  Dim SBlk As Range, SCll As Range, Tmp As String, OldSCll As String, Separator As String
  Dim TBlk As Range, TCllE As Range, TCllK As Range, TOfsR As Long, TOfsC As Integer
  ' cilove bloky
  With Worksheets("sheet2")
    Set TBlk = .Range("a1:j1")
    Set TCllE = .Range("e1")
    Set TCllK = .Range("k1")
  End With
  TOfsR = -1
  With Worksheets("sheet1")
    Set SBlk = .Range("f1:f" & .Cells(Rows.Count, 1).End(xlUp).Row)  ' zdoj blok
  End With
  ' prohledavat SBlk
  OldSCll = vbNullString
  For Each SCll In SBlk.Cells
    Tmp = SCll.Offset(0, -4).Value & SCll.Offset(0, -1).Value & SCll.Value  ' sloupce B, E, F
    If Tmp <> OldSCll Then  ' nova skupina
      OldSCll = Tmp  ' ulozit novy stav sloupce B, E, F
      ' prenest blok  Ax:Jx
      TOfsR = TOfsR + 1  ' ofset radku na cilovem listu
      TOfsC = 0  ' ofset sloupce
      Separator = " "
      TBlk.Offset(TOfsR, 0).Value = SCll.Resize(1, 10).Offset(0, -5).Value  ' Ax:Jx
    End If
    With TCllE.Offset(TOfsR, 0)
      .Value = .Value & Separator & SCll.Offset(0, -5).Value  ' pridat do sl E:E hodnotu ze sloupce A:A
    End With
    ' hodnoty ze sloupce A,I, H do K (L, ...) pro prvni a dalsi shodne vyrobky
    With SCll
      TCllK.Offset(TOfsR, TOfsC).Value = .Offset(0, -5).Value & ":" & .Offset(0, 3).Value & ";" & .Offset(0, 2).Value
    End With
    Separator = ", "
    TOfsC = TOfsC + 1  ' ofset sloupcu
  Next SCll
  With Worksheets("sheet2")
    .Range(.UsedRange.Address).Columns.AutoFit  ' upravit sirku sloupcu
  End With
  Set SBlk = Nothing
  Set SCll = Nothing
  Set TBlk = Nothing
  Set TCllE = Nothing
  Set TCllK = Nothing
End Sub