Rozdelenie zlucenychbuniek a vpysanie obsahu do kazdej Vyřešeno

[arasid]

Zdravim,
mam este jeden problem.. Mozno na to existuje aj banalne riesenie, ale asi na to ani VBA nepostaci:
Potreboval by som vo velkej tabulke, ktora obsahuje vela rozne zlucenych buniek (vzdy len v ramci jedneho stlpca) rozdelit vsetky zlucene bunky a povodny text vpisat do kazdej bunky co po rozdeleni povodnej bunky vznikla..

mam totizto jednu strasne velku nemotorne spravenu tabulku a chcem ju upravit pre pouzitie Pivot.. Len ak sa to bude robit po jednom tak pri tom aj zostrnem :/..

[Reklama]

[Azuzula]

Ahoj, co třeba označit všechny sloučené buňky a všechny najednou rozdělit a celý sloupec pak kopírovat doprava?

[arasid]

no proste zlucene bunky ubsahuju daky text a ja po ich rozdeleni chcem aby dany text obsahovala kazda jedna bunka z povodnej zlucenej..
spravil som priklad v prilozenom subore..

[cmuch]

Ještě by šlo takto.
Označit sloupec a odstranit sloučení buněk
a pak pokračovat dle tohoto:
Fill Blank Cells Manually
http://www.contextures.com/xlDataEntry02.html

[arasid]

no skusal som to.. funguje trochu divne a nemozem to pouzit, lebo moja tabulka obsahuje v stlpci medzi zlucenymi bunkami aj prazdne bunky bez hodnoty, takze ak ho spustim vyplni mi aj tie bunky co nechcem..
preto potrebujem nieco co skopci hodnotu v zlucenej bunke a vyplni nou LEN tie bunky, ktore vznikli po rozdeleni..

[Azuzula]

Taky jsem se chtěla podívat na ten přiložený soubor, ale excel mi napsal, že to nemůže otevřít kvůli vadnému soboru nebo neodpovídající koncovce... Co je s tím souborem špatně?

[cmuch]

Tady jsem udělal makro.
Akorát si uprav list a sloupec (v makru je to první list sešitu a sloupec B)

Kód: Vybrat vše

Sub ZapisDoRozdelenychBunek()

  Dim BlkA As Range
 
  Dim rng As Range
  Dim MergeArea As Range
  Dim MA_C, MA_FR, MA_LR As Integer
  Dim MA_V As Variant

  ' definovani bloku bunek na listu (zde prvni list a sloupec B)
    Set BlkA = Worksheets(1).Range(("b1:b") & Cells(Rows.Count, "b").End(xlUp).Row)
 
  Application.ScreenUpdating = False

    ' prochazet BlkA
    For Each CllA In BlkA.Cells
       
        Set rng = CllA
        Set MergeArea = rng(1).MergeArea

        If MergeArea.Address = rng.Address Then
            GoTo Err
        End If
     
        MA_C = MergeArea.Column                     'Sloupec sloucenych bunek
        MA_FR = MergeArea.Row                       'Prvni radek sloucenych bunek
        MA_LR = MA_FR + MergeArea.Rows.Count - 1    'Posledni radek sloucenych bunek
        MA_V = Cells(MA_FR, MA_C)                   'Hodnota sloucenych bunek

        rng.UnMerge                                             'Rozdeleni slouc.bunek
        Range(Cells(MA_FR, MA_C), Cells(MA_LR, MA_C)) = MA_V    'Zapis do roz.bunek
Err:
    Next CllA
     
  Application.ScreenUpdating = True

  ' odstranit objektove promenne
  Set BlkA = Nothing
  Set rng = Nothing
  Set MergeArea = Nothing
 
End Sub


Snad je to co potřebuješ.

[arasid]

Diky chlape :).. take nieco som hladal..
Sorac za ten subor, ak nejde otvorit asi preto, lebo som to nahraval s firmy a zakodoval to bezpecnostny system :/..