PC-HELP.CZ

Dobrý den,
potřeboval bych poradit. Potřeboval bych vytvořit makro, které by umělo z Excelu

před.xlsx: (11.61 KiB) Staženo 62 x

vytvořit Excel

po.xlsx: (29.6 KiB) Staženo 60 x

Popis práce Makra:
V

před.xlsx: (11.61 KiB) Staženo 62 x

jsou v List1 jsou dva sloupce(B, C) a v List2 je tabulka
Potřebuji
-vytvořit tolik listů kolik je plných buněk v prvním sloupci v List1, prázdné řádky vynechat (v příkladu: 9 plných řádků = 9 vytvořených listů)
-pojmenovat každý list podle prvního sloupce (v příkladu: 1. vytvořený list se bude jmenovat: D.1
2. vytvořený list se bude jmenovat: PS 01-01-01)
-do listů, kterým začíná jméno buď na "PS" nebo "SO" nebo číslo se vloží tabulka z List2
- do těchto tabulek se
a) do buňky C3 vloží odpovídající text z 1. sloupce z list1
b) do bunky A5 vloží odpovídající text z 2. sloupce z list1
- do listů, kterým NEzačíná jméno buď na "PS" nebo "SO" nebo číslo se vloží
a) do bunky B9 text odpovídající text z 1. sloupce z list1
b) do bunky C9 se vloží odpovídající text z 2. sloupce z list1
- do 1. sloupce v List1 vložit hypertextový odkaz, který bude odkazovat na příslušný list

Díky moc za pomoc

Pod pojmom "vložit" sa rozumie vždy hodnota. Vy máte ale v príklade výsledku vzorce. To je fuk, tu máte verziu kde je jasné v makre, že riadky s .Value vkladajú hodnotu (teraz zelené, vyradené apostrofom z činnosti), a riadky s .Formula vkladajú vzorce.

Pozor! Nieje to ošetrené na situáciu, že:
a) v bunkách budú znaky, ktoré nesmú byť použité v názvoch listov
b) v bunkách je viac znakov ako 31 (maximálna dĺžka názvu listu)
c) list s daným názvom už existuje

Ďalej si dajte pozor aj na to, aby ste v bunkách nemal prebytočné medzery, ako teraz pred " D.2" a " E.1.6"

Kód: Vybrat vše

Sub VytvorListy()
Dim D(), Radku As Long, i As Long, Idx As Integer, WS As Worksheet

    With wsData
        Radku = .Cells(Rows.Count, 2).End(xlUp).Row - 1
        If Radku = 0 Then MsgBox "Chybějí data", vbExclamation: Exit Sub
        D = .Cells(2, 2).Resize(Radku, 2).Value2
    End With
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook
        Idx = .Worksheets.Count
        For i = 1 To Radku
            If Not IsEmpty(D(i, 1)) Then
                If Left$(D(i, 1), 2) = "PS" Or Left$(D(i, 1), 2) = "SO" Or IsNumeric(Left$(D(i, 1), 1)) Then
                    wsSablona.Copy After:=.Worksheets(Idx)
                    Set WS = .Worksheets(Idx + 1)
                    With WS
                        '.Cells(3, 3).Value = D(i, 1)
                        '.Cells(5, 1).Value = D(i, 2)
                        .Cells(3, 3).Formula = "='" & wsData.Name & "'!B" & i + 1
                        .Cells(5, 1).Formula = "='" & wsData.Name & "'!C" & i + 1
                    End With
                Else
                    .Worksheets.Add After:=.Worksheets(Idx)
                    Set WS = .Worksheets(Idx + 1)
                    With WS.Cells(9, 2).Resize(, 2)
                        '.Value = Array(D(i, 1), D(i, 2))
                        .Formula = Array("='" & wsData.Name & "'!B" & i + 1, "='" & wsData.Name & "'!C" & i + 1)
                        With .Font
                            .Bold = True
                            .Size = 12
                            .Name = "Arial CE"
                        End With
                    End With
                End If
                
                Idx = Idx + 1
                WS.Name = D(i, 1)
                wsData.Hyperlinks.Add Anchor:=wsData.Cells(i + 1, 2), Address:="", SubAddress:="'" & D(i, 1) & "'!A1", TextToDisplay:=CStr(D(i, 1))
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

Dobrý den,
to je skvělé. Moc Vám děkuji. :thumbup:

PC-HELP.CZ

Excel VBA - práce s listy

Excel VBA - práce s listy

Re: Excel VBA - práce s listy

Re: Excel VBA - práce s listy