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
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
Užitočné (1) | Kabaka123 |
Excel-makro úprava tabuľky.