Excel makro - vložit řádek podle hodnoty

Programy pro práci s textem, tabulkami, prezentacemi

Moderátor: Moderátoři Živě.cz

Odeslat příspěvekod venousekh 23. 2. 2021 08:28

Ahoj,

potřeboval bych pomoct s makrem v Excelu. Mám sloupec hodnot v excelu, které jsou seřazeny a některá hodnota je v něm vícekrát. Potřeboval bych makrem vložit před každou skupinu stejných hodnot řádek a vložit do něj hodnotu z řádku pod nim. Aby výsledek vypadal takto.

Vím, že je to o nějakém makru na osm deset řádků, ale já si s tím nevím rady. Pokud by mi někdo pomohl, byl bych mu vděčný.

díky moc

Untitled.jpg
Intel Dual Core 2 E2180 , deska GB P35-DS3L , 2x1024 MB DDRII dual channel 800MHz Extreme, ATI Radeon HD 3650 512MB DDR3 , Seagate 160GB SATAII + Seagate 250GB SATAII , DVDRW LG H22N , Windows 10 Pro ( or Lenovo B580 , Windows 10 Pro )
venousekh
Junior

Odeslat příspěvekod StalkerX 23. 2. 2021 21:54

Kód pracuje pod prvním listem s sloupcem B
Kód: Vybrat vše
Option Explicit

Sub VlozHlavicky()

Dim Uniq As Collection, arrUniq()
Dim i As Long, Radku As Long
Dim rng As Range
Application.ScreenUpdating = False
With List1
    Radku = .Cells(Rows.Count, 2).End(xlUp).Row
    If Radku = 1 Then
        MsgBox "Žádná data ke spracování.", vbExclamation, "Chyba"
        Exit Sub
       ElseIf Radku = 2 Then
        ReDim arrUniq(1 To 1, 1 To 1)
        arrUniq(1, 1) = .Cells(2, 2).Value
       Else
        arrUniq = .Cells(2, 2).Resize(Radku - 1).Value
    End If

Set Uniq = New Collection

On Error Resume Next
    For i = LBound(arrUniq) To UBound(arrUniq)
        Uniq.Add arrUniq(i, 1), CStr(arrUniq(i, 1))
    Next i
On Error GoTo 0

For i = 1 To Uniq.Count
    Set rng = .Range("B:B").Find(What:=Uniq.Item(i), _
          LookIn:=xlValues, _
          LookAt:=xlWhole, _
          SearchOrder:=xlByRows, _
          SearchDirection:=xlNext, _
          MatchCase:=False)
         
          If Not rng Is Nothing Then
          With rng
            .EntireRow.Insert
            With .Offset(-1)
                 .Value = Uniq.Item(i)
                 .Font.Bold = True
                 .Interior.Color = 14998742
            End With
          End With
          End If
Next i
End With
Application.ScreenUpdating = True

Set rng = Nothing
Set Uniq = Nothing
Erase arrUniq
End Sub
StalkerX
Kolemjdoucí


Kdo je online

Uživatelé procházející toto fórum: Žádní registrovaní uživatelé a 0 návštevníků