Transponování pole hodnot Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

Kurimak
nováček
Příspěvky: 17
Registrován: leden 16
Pohlaví: Muž
Stav:
Offline

Transponování pole hodnot

Příspěvekod Kurimak » 23 srp 2018 06:34

Ř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
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 380
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Transponování pole hodnot

Příspěvekod elninoslov » 23 srp 2018 09:30

Č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
Pohlaví: Nespecifikováno

Re: Transponování pole hodnot

Příspěvekod guest » 23 srp 2018 10:33

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

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 380
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Transponování pole hodnot

Příspěvekod elninoslov » 23 srp 2018 11:08

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...
Přílohy
Trans+Insert.xlsm
(19.68 KiB) Staženo 30 x

Kurimak
nováček
Příspěvky: 17
Registrován: leden 16
Pohlaví: Muž
Stav:
Offline

Re: Transponování pole hodnot  Vyřešeno

Příspěvekod Kurimak » 24 srp 2018 08:33

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



Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 0 hostů