nahrazení buňěk ze sloupců do řádků

[Darina85]

Ahoj. Bojuji s jednou úlohou...představme si tabulku viz...


c.o. schvalovatel
22 turek
22 pucek
23 pridala
24 turek
24 lovnanska
24 bydzovska
24 repka
25 mazura
25 kacerovsky
25 novak
26 turek
26 lovnanska
27 repka
28 turek
28 mazura
28 prusa
29 sebesta


c.o.-cislo objednavky...potrebuji dostat, kde je vice stejnych cisel objednavek (22,22 napr) a dva schvalovatele, dostat je do jednoho radku, asi takhle... "22 turek pucek." Pricemz kazde jmeno bude v jednom sloupci. Cisla se mi spoji v pivot table a prekopiruji je pod sebe, ale potrebuji nejaky vzorec, popr. makro, které mi seřadí u více stejných čísel objednávek jména do řádku, každé v jiném sloupci. Díky.

[Reklama]

[d1amond]

Vítej na PC-HELP

Bude vždy kombinace jméno - číslo jedinečná? A nebo se může stejné číslo a stejné jméno vyskytnou vícekrát.

[Darina85]

ahoj. díky za uvítání. U každého čísla objednávky se nikdy nebude opakovat stejné méno. Vždy bude číslo a jména (1-5 jmen u jedné objednávky) jedinečné, přičemž se jména opakují u jiných čísel objednávek. tzn že bude stejné jméno třeba ve 22, 24, 25, 27 atd...pro příklad.

--- Doplnění předchozího příspěvku (24 Dub 2012 11:51) ---

už jsem to nějak zpatlal...udělal jsem to přes offset a podímku if

[d1amond]

Tady dávám řešení přes pole, kde se data řadí sestupně a to jak pro čísla objednávek, tak i pro jména, která k nim patří.

SloupceNaRady_Unikatni.xlsm

(22.05 KiB) Staženo 41 x

Je tam i šikovná procedura "QuickSort" s parametrem, která řadí prvky pole. Někomu se třeba hodí.

Kód: Vybrat vše

Option Explicit
Sub SloupceNaRadek()
Dim wsh As Worksheet
Dim rng As Range
Dim r As Integer
Dim cell As Range
Dim strCisO As String 'cislo objednavky
Dim arr1() As String
Dim arr2() As String
Dim strJmena As String
Dim i As Integer
Dim j As Integer

Application.ScreenUpdating = False

Set wsh = ThisWorkbook.Worksheets(1)
With wsh
r = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("A1:A" & r)

'projde rng a zajisti unikatni cisla objednavek
For Each cell In rng
If cell.Value <> "" Then
    If InStr(1, strCisO, cell.Value, vbTextCompare) = 0 Then
        If strCisO <> "" Then
            strCisO = strCisO & "," & cell.Value
            Else: strCisO = cell.Value
        End If
    End If
End If
Next

arr1 = Split(strCisO, ",")
'serazeni prvku pole
QuickSort arr1, LBound(arr1), UBound(arr1)

'naplni data od sloupce E
For i = LBound(arr1) To UBound(arr1)
    With .Cells(i + 1, 5)
    .Value = arr1(i)
    .Select
    strJmena = JmenaKObjednavce(ActiveCell.Value)
    arr2 = Split(strJmena, ",")
    'serazeni prvku pole
    QuickSort arr2, LBound(arr2), UBound(arr2)
    'naplneni jmen k objednavce
    For j = LBound(arr2) To UBound(arr2)
        If arr2(j) <> "" Then
            ActiveCell.Offset(0, j).Value = arr2(j)
        End If
    Next
    End With
Next
End With

Application.ScreenUpdating = True

End Sub

'prevzato z http://officir.ic.cz/chipex05/11/excel_vba_algo.html
Sub QuickSort(Pole As Variant, DolniMez As Long, HorniMez As Long)
   Dim Pivot As Variant
   Dim k As Variant
   Dim i As Long
   Dim j As Long
   i = DolniMez
   j = HorniMez
   Pivot = Pole((DolniMez + HorniMez) \ 2)
   While (i <= j)
      While (Pole(i) < Pivot And i < HorniMez)
         i = i + 1
      Wend
      While (Pivot < Pole(j) And j > DolniMez)
         j = j - 1
      Wend
      If (i <= j) Then
         k = Pole(i)
         Pole(i) = Pole(j)
         Pole(j) = k
         i = i + 1
         j = j - 1
      End If
   Wend
   If (DolniMez < j) Then QuickSort Pole, DolniMez, j
   If (i < HorniMez) Then QuickSort Pole, i, HorniMez
End Sub

Function JmenaKObjednavce(i As String) As String
Dim wsh As Worksheet
Dim r As Integer
Dim rng As Range
Dim cell As Range
Dim strJmena As String


Set wsh = ThisWorkbook.Worksheets(1)
With wsh
r = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("A1:A" & r)

For Each cell In rng
    If cell.Value = i Then
        strJmena = strJmena & "," & cell.Offset(0, 1).Value
    End If
Next
End With

JmenaKObjednavce = strJmena
End Function