nahrazení buňěk ze sloupců do řádků
Napsal: 23 dub 2012 20:33
od 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.
Re: nahrazení buňěk ze sloupců do řádků
Napsal: 23 dub 2012 21:09
od 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.
Re: nahrazení buňěk ze sloupců do řádků
Napsal: 24 dub 2012 06:49
od 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
Re: nahrazení buňěk ze sloupců do řádků
Napsal: 24 dub 2012 20:34
od 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ří.
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