Transponování pole hodnot Vyřešeno

[Kurimak]

Řeším problém s transpozicí pole hodnot. Mám buňky které obsahují hodnoty oddělené čárkou. Potřebuji je dostat do sloupce, do každé buňky hodnotu zvlášť. Použil jsem funkci WorksheetFunction.Transpose(Pole). Ta mi však vloží pouze první hodnotu z pole a ostatní ne. Pole vytvořené pomocí funkce Split, by však mělo být vytvořené správně, neboť podle horní hodnoty počtu člení pole Ubound(Pole) se mi vkládají počty řádků. Druhé makro Bunka_do_sloupce mi funguje, jenže tam je absolutní adresování na sloupce.

For Each bCell In OblastId.Cells
Pole() = Split(bCell.Offset(0, RozdilData).Value, Oddelovac)
If UBound(Pole) > 0 Then
Range(bCell.Offset(1, 0), bCell.Offset(UBound(Pole), 1)).EntireRow.Insert

'Problémová část kódu:
Range(bCell.Offset(0, RozdilVysledek), bCell.Offset(UBound(Pole), RozdilVysledek)).Value = _ WorksheetFunction.Transpose(Pole)

Else
bCell.Offset(0, RozdilVysledek).Value = bCell.Offset(0, RozdilData).Value
End If

Next bCell


Správně funguje:

Sub Bunka_do_sloupce()
Dim i As Integer
Dim Pole() As String
Dim Oddelovac As String

i = 1
Oddelovac = ","

Do Until Cells(i, 1) = ""
Pole() = Split(Cells(i, 2).Value, Oddelovac)
If UBound(Pole) > 0 Then
Range(Cells(i + 1, 1), Cells(i + UBound(Pole), 1)).EntireRow.Insert
Range(Cells(i, 3), Cells(i + UBound(Pole), 3)).Value = WorksheetFunction.Transpose(Pole)
i = i + 1 + UBound(Pole)
Else
Cells(i, 3).Value = Cells(i, 2).Value
i = i + 1
End If
Loop

End Sub

[Reklama]

[elninoslov]

Čo je RozdilData a RozdilVysledek ? Priložte radšej nejaký súbor, nech si urobíme celkový obraz. Polia používam rád, ale majú isté obmedzenia. Funkcia Transpose transponuje max 32767 prvkov, defaultné usporiadanie je opačné ako v liste (v liste je prvý parameter výška, vo VBA Split šírka), ... Použite radšej .Resize() ako Range(Offset(), Offset()). Proste priložte prílohu ...

[guest]

Kromě toho... Data / Text do sloupců.

[elninoslov]

Príklad zápisu cez 1 spoločné pole (čo najmenej prechodov medzi VBA a listom). A napadá ma ďalšie, ešte rýchlejšie, kde by sa nevkladali riadky, ale prepísali by sa aj zdrojové bunky spoločným poľom s výsledkom (3 stĺpce). Záleží na prílohe, čo ste nedal, aby bolo jasné ako to vyzerá aj okolo, čo tam chcete dosiahnuť, a pod...

[Kurimak]

Zdravím,
příkaz Data/Text do sloupců znám. Potřeboval jsem převést velké množství buněk s jejich hodnotami oddělenými čárkou do jednoho sloupce. Proto to makro.
Chyba byla v:
Else
bCell.Offset(0, RozdilVysledek).Value = bCell.Offset(0, RozdilData).Value, neboť makro procházelo nově vložené řádky a přemazalo buňky s vyplněnými hodnotami.
Proto jsem kód upravil: ElseIf UBound(Pole) = 0 And bCell.Value <> "" Then.........
a makro začalo fungovat. Nechtěl jsem však, aby bylo zbytečně zpomalováno vyhodnocováním každé buňky v prvním sloupci vložených řádků, tak jsem makro částečně po vzoru v sešitu Trans-insert.xlsm upravil tak, aby se vyhodnocovaly pouze původní řádky a vložené byly přeskakovány. RozdilData a RozdilVysledek jsou hodnoty, které vyjadřují relativní posun ve sloupcích, které obsahují data pro zpracování a výsledek oproti sloupci s IDentifikátorem řádku. Děkuji za radu. Výsledný kód uvádím níže, je součástí formuláře:

Private Sub cmdProvest_Click()
Dim Id As Range, Data As Range, Vysledek As Range, Oddelovac As String
Dim BunkaId As Range, BunkaData As Range, BunkaVysledek As Range
Dim SloupecId As Long, SloupecData As Long
Dim OblastId As Range
Dim RozdilData As Long, RozdilVysledek As Long
Dim PocetBunek As Long, KontBunka As Range
Dim Pole() As String, RadekId As Long, PocetRadku As Long, i As Long


'Ověření zamčení listu
On Error GoTo Chyba
If ActiveSheet.ProtectContents Then
MsgBox "Sešit je uzamčen pro úpravy obsahu.", vbCritical, "Upozornění!"
Exit Sub
End If

'Ověření výběru oblasti dat
If refID <> vbNullString Or refData <> vbNullString Or refVysledek <> vbNullString Then
On Error GoTo Chyba
Set Id = Range(refID.Text)
Set Data = Range(refData.Text)
Set Vysledek = Range(refVysledek.Text)
Else: MsgBox "Vyberte první buňky (1) oblasti.", vbInformation
Exit Sub
End If




'Definování oblasti pro zpracování dat
Set BunkaId = Id.Cells(1, 1)
Set BunkaData = Data.Cells(1, 1)
Set BunkaVysledek = Vysledek.Cells(1, 1)
SloupecId = BunkaId.Column
SloupecData = BunkaData.Column
SloupecVysledek = BunkaVysledek.Column
SloupecData = BunkaData.Column
SloupecVysledek = BunkaVysledek.Column
Set KontBunka = Cells(Rows.Count, SloupecId)
'Nastavení oblasti zpracování po kontrole vyplněnosti poslední buňky
If IsEmpty(KontBunka) Then
Set OblastId = Intersect(Range(BunkaId, Cells(Rows.Count, SloupecId).End(xlUp)), BunkaId.CurrentRegion)
Else
Set OblastId = Range(BunkaId, Cells(Rows.Count, SloupecId))
End If

RozdilData = SloupecData - SloupecId
RozdilVysledek = SloupecVysledek - SloupecId


'Vypnutí překreslování
Application.ScreenUpdating = False




'Definování prvního řádku a počtu řádků pro zpracování
RadekId = BunkaId.Row
PocetRadku = OblastId.Rows.Count

'Ověření zadání oddělovače
Oddelovac = txtOddelovac.Value
If Oddelovac = "" Then
MsgBox "Oddělovač hodnot nebyl zadán.", vbCritical, "Chyba!"
Exit Sub
End If



'Tvorba oblastí se stejnou hodnotou a jejich slučování
If Not OblastId Is Nothing Then


'Procházení každé buňky ve sloupci s ID
For i = 1 To PocetRadku
Pole() = Split(Cells(RadekId, SloupecData).Value, Oddelovac)

If UBound(Pole) > 0 Then

Range(Cells(RadekId, SloupecId).Offset(1, 0), (Cells(RadekId + UBound(Pole), SloupecId))).EntireRow.Insert
Range(Cells(RadekId, SloupecVysledek), Cells(RadekId + UBound(Pole), SloupecVysledek)).Value = _
WorksheetFunction.Transpose(Pole)
RadekId = RadekId + 1 + UBound(Pole)
ElseIf UBound(Pole) = 0 And Cells(RadekId, SloupecId).Value <> "" Then

Cells(RadekId, SloupecVysledek).Value = Cells(RadekId, SloupecData).Value
RadekId = RadekId + 1
End If


Next i
End If




'Zarovnání sloupců
BunkaVysledek.Columns.EntireColumn.AutoFit

Application.ScreenUpdating = True
Beep



Unload Me

Exit Sub

'Chybová rutina
Chyba:
MsgBox "Nesprávně vybraná oblast.", vbCritical, "Chyba!"
Exit Sub


End Sub