midke
17.01.18,07:52
Dobrý deň
Vedel by mi prosím niekto poradiť nejaké makro, ktoré by mi sformátovalo tabuľku v
Exceli do požadovaného tvaru.
Bližší popis v priloženom súbore.
Ďakujem
elninoslov
17.01.18,09:30
Samozrejme to ale nebude fungovať na tabuľke, ktorá už je raz upravená tak ako chcete. Funguje to iba na neupravenej.
Sub FormatujTabulku()
Dim Riadkov As Long, Meno(), MenoN(), Pocet As Long, y As Long, i As Long, d As Long, Adr As String, A As String, Vlozene As Boolean

Application.ScreenUpdating = False

With ThisWorkbook.Worksheets("Hárok1")
Riadkov = .Cells(Rows.Count, 3).End(xlUp).Row - 1
If Riadkov < 2 Then Exit Sub
ReDim Meno(1 To Riadkov, 1 To 1)
Meno = .Cells(2, 3).Resize(Riadkov).Value2

For i = 1 To Riadkov
Pocet = Pocet + 1
ReDim Preserve MenoN(1 To 1, 1 To Pocet)

If i > 1 Then
If Meno(i, 1) <> Meno(i - 1, 1) Then
Pocet = Pocet + 1
ReDim Preserve MenoN(1 To 1, 1 To Pocet)
MenoN(1, Pocet) = Meno(i, 1)

y = y + 1
A = .Cells(d + i + 1, 1).Resize(, 4).Address
If Len(Adr) + Len(A) + 1 > 255 Then
.Range(Adr).Insert Shift:=xlDown: Adr = "": Vlozene = True: d = d + y: y = 0
Else
Adr = Adr & IIf(Adr = "", "", ",") & A: Vlozene = False
End If

End If
Else
MenoN(1, Pocet) = Meno(i, 1)
End If
Next i

If Vlozene = False Then .Range(Adr).Insert Shift:=xlDown
.Cells(2, 3).Resize(Pocet).Value2 = WorksheetFunction.Transpose(MenoN)
End With

Application.ScreenUpdating = True
Erase Meno: Erase MenoN
End Sub

No a ak by sa jednalo iba o čisté dáta, bude stačiť úprava výhradne na pole dát, nie na vkladanie riadkov, čo bude rýchlejšie. Takto to zachová aj prípadné formáty. Keď bude čas pridám a ver. čisto cez pole dát...

EDIT:
Táto verzia pracuje iba s poľom dát. Na veľké množstvo dát bude rýchlejšia, ale nezaujímajú ju formáty:

Sub FormatujTabulkuPole()
Dim Riadkov As Long, Data(), DataN(), Pocet As Long, i As Long, Meno As Boolean

Application.ScreenUpdating = False

With ThisWorkbook.Worksheets("Hárok1")
Riadkov = .Cells(Rows.Count, 3).End(xlUp).Row - 1
If Riadkov < 2 Then Exit Sub
ReDim Data(1 To Riadkov, 1 To 4)
Data = .Cells(2, 1).Resize(Riadkov, 4).Value2
Meno = True

For i = 1 To Riadkov
Pocet = Pocet + 1
If i > 1 Then
If Data(i, 3) <> Data(i - 1, 3) Then
Pocet = Pocet + 1
Meno = True
Else
Meno = False
End If
End If
ReDim Preserve DataN(1 To 4, 1 To Pocet)
DataN(1, Pocet) = Data(i, 1): DataN(2, Pocet) = Data(i, 2): DataN(4, Pocet) = Data(i, 4)
If Meno Then DataN(3, Pocet) = Data(i, 3)
Next i

.Cells(2, 1).Resize(Pocet, 4).Value2 = WorksheetFunction.Transpose(DataN)
End With

Application.ScreenUpdating = True
Erase Data: Erase DataN
End Sub
midke
17.01.18,10:25
Toto vyzerá skvelo, musím ešte odskúšať na viacero údajov. Skvelá práca, chcel by som sa to aj ja niekedy naučiť, len neviem kde. Ešte raz veľmi pekne ďakujem.
elninoslov
17.01.18,18:16
Pridal som aj riešenie pomocou poľa dát ... Ešte si treba rozmyslieť, či môže nastať, že výsledok bude mať viac ako 30000 riadkov. Ak áno, tak sa nemôže kvôli obmedzeniu použiť metóda Transpose, ale musí sa pole preklopiť cyklom (to je zlomok sekundy) - v prípade potreby dorobím...