EXCEL - uprava a třídění dat Vyřešeno

[kangerou78]

Dobrý den,

mám menší problém s porovnáním dat v excelu. Potřeboval bych pospojovat pole, za podmínky, že sloupce A, B, E, F jsou stejné, data jsou vždy pod sebou. Potřeboval bych provést změnu, aby se mi data porovnávala a zapisovala do řádku. Lépe pochopitelné a ukázané je to v přiloženém souboru.

Děkuji moc

[Reklama]

[Branscombe]

Pakliže to chápu správně, tak potřebuješ odebrat duplicitní položky.
V Excel 2007 a výše je na kartě "Data" položka "Odebrat duplicity", v dřívějších verzích si nejsem jist přítomností této funkce, takže označíš oblast buněk, klikneš na odebrat duplicity a pak jen vybereš které pole chceš porovnávat ... Na závěr vložíš vzorec do posledního sloupce který ti vybere data ze sloupce D

[kangerou78]

Nepotřebuju odebrat duplicitní položky, potřebuju, aby mi to z jednoho listu vyhledávalo a na druhý list řadilo položky, dle výsledku ve výše uvedeném souboru ukázka.xls. Problém mám v tom, že záznamů může být různý počet a to jak celkových tak i pro jednotlivé položky. Potřebuju, aby na listu1 byly záznamy zachovány jak jsou a na list2 by se mi zobrazil výsledek po setřídění. Tak jak je uvedeno v ukázce.

[navstevnik]

Plati, pokud je shodne VP, je shodne i Cvykresu a Polozka? Tedy nenastane stav, kdy pro shodne VP jsou ruzna Cvykresu a Polozka?

[kangerou78]

Ano, platí. Stav že by se VP, Cvykresu a Položka neshodovali nastat nemůže.

[navstevnik]

Nize uvedenou proceduru vloz do standardniho modulu, zavolat F5 v editoru VBA nebo z listu Nastroje>Makro>... (uprav nazvy listu dle potreby, otestuj na zaloze a s vetsim poctem zaznamu, zejmena kombinace zakazky a VP; plati, ze data na listu1 jsou setridena - pod sebou):

Kód: Vybrat vše

Option Explicit

Sub Sestavit()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  Dim OldZak As String, OldVP As String
  With Worksheets("list1")
    Set SBlk = .Range("a2:a" & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  Set TCll = Worksheets("list2").Range("a1")
  OldZak = vbNullString
  OldVP = vbNullString
  OffsR = 0
  For Each SCll In SBlk.Cells
    With SCll
      If CStr(.Value) = OldZak And CStr(.Offset(0, 1).Value) = OldVP Then
        TCll.Offset(OffsR, 6).Value = TCll.Offset(OffsR, 6).Value & ", " & CStr(.Offset(0, 3).Value)  ' '2_c_prac
      Else
        If CStr(.Offset(0, 1).Value) <> OldVP Then
          OffsR = OffsR + 1
          OldZak = CStr(.Value)
          OldVP = CStr(.Offset(0, 1).Value)
          TCll.Offset(OffsR, 0).Value = CStr(.Value)  ' zakazka
          TCll.Offset(OffsR, 1).Value = CStr(.Offset(0, 1).Value)  ' VP
          TCll.Offset(OffsR, 3).Value = .Offset(0, 4).Value  ' Cvykresu
          TCll.Offset(OffsR, 4).Value = .Offset(0, 5).Value  ' Polozka
          TCll.Offset(OffsR, 5).Value = .Offset(0, 6).Value  ' ks
          TCll.Offset(OffsR, 6).Value = CStr(.Offset(0, 3).Value)  ' '2_c_prac
        End If
      End If
    End With
  Next SCll
  Worksheets("list2").UsedRange.EntireColumn.AutoFit
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

[kangerou78]

Díky moc, je to super, funguje to :-) Jen bych ještě potřeboval, aby mi to ve sloupci 2_c_prac vypisovalo i ty nuly na začátku. Všechny čísla by měla být 5 místná.

[navstevnik]

Vsechny sloupce na listu 2 mimo slopec pro pocet naformatuj predem jako text.
Pro jednodussi pouzit upravena procedura vlozi na list 2 hlavickovy radek a naformatuje sloupce.

Kód: Vybrat vše

Option Explicit

Sub Sestavit()
  Dim SWsht As Worksheet, TWsht As Worksheet
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  Dim OldZak As String, OldVP As String, i As Byte

  Set SWsht = ActiveWorkbook.Worksheets("list1")
  Set TWsht = ActiveWorkbook.Worksheets("list2")
  With SWsht
    Set SBlk = .Range("a2:a" & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  With TWsht
    Set TCll = .Range("a1")
    .Cells.ClearContents
    For i = 0 To 6
      ' vlozit hlavicky
      With SWsht.Range("a1")
        TCll.Value = .Value
        TCll.Offset(0, 1).Value = .Offset(0, 1).Value
        TCll.Offset(0, 2).Value = .Offset(0, 2).Value
        TCll.Offset(0, 3).Value = .Offset(0, 4).Value
        TCll.Offset(0, 4).Value = .Offset(0, 5).Value
        TCll.Offset(0, 5).Value = .Offset(0, 6).Value
        TCll.Offset(0, 6).Value = .Offset(0, 3).Value
      End With
    Next i
    .Range("a:e,g:g").NumberFormat = "@" ' format sloupcu
  End With
  OldZak = vbNullString
  OldVP = vbNullString
  OffsR = 0
  For Each SCll In SBlk.Cells
    With SCll
      If CStr(.Value) = OldZak And CStr(.Offset(0, 1).Value) = OldVP Then
        TCll.Offset(OffsR, 6).Value = TCll.Offset(OffsR, 6).Value & ", " & CStr(.Offset(0, 3).Value)  ' '2_c_prac
      Else
        If CStr(.Offset(0, 1).Value) <> OldVP Then
          OffsR = OffsR + 1
          OldZak = CStr(.Value)
          OldVP = CStr(.Offset(0, 1).Value)
          TCll.Offset(OffsR, 0).Value = CStr(.Value)  ' zakazka
          TCll.Offset(OffsR, 1).Value = CStr(.Offset(0, 1).Value)  ' VP
          TCll.Offset(OffsR, 3).Value = .Offset(0, 4).Value  ' Cvykresu
          TCll.Offset(OffsR, 4).Value = .Offset(0, 5).Value  ' Polozka
          TCll.Offset(OffsR, 5).Value = .Offset(0, 6).Value  ' ks
          TCll.Offset(OffsR, 6).Value = CStr(.Offset(0, 3).Value)  ' '2_c_prac
        End If
      End If
    End With
  Next SCll
  TWsht.UsedRange.EntireColumn.AutoFit
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
  Set SWsht = Nothing
  Set TWsht = Nothing
End Sub

[kangerou78]

Funguje to parádně, děkuji moc :-)