EXCEL - sloučení buněk podle hodnoty Vyřešeno

[Račis]

Zdravím.

Přemýšlím, zda jde ( podlě mě v excelu jde vše ) udělat, aby podle zadané hodnoty v jedné buňce se mi sloučili buňky v nějaké oblasti. Praxe by byla taková (viz příklad), že kdybych v buňce B2 napsal hodnoty od 1 do 3, tak by se mi sousední buňky sloučily na:

1 velkou (hodnota 1, sloučeno 6 buněk v 1)
2 střední (hodnota 2, sloučeno 6 buněk v 2 (2x3))
3 malé (hodnota 3, sloučeno 6 buněk na 3 (3x2))

A dále pak, se do těchto buněk přenesl předem nadefinovaný vzorec.

[Reklama]

[Azuzula]

Podle mých zkušeností jde v excelu udělat téměř všechno, tohle je hračka Mrkni do přílohy, makro je v modulu listu, stačí si tam upravit rozsahy buněk a vzorce.
Opravila jsem ještě chybku, makro nebude už upozorňovat na přepsání dat v buňkách.

[Račis]

Dokonalé - funguje přesně podle mých představ :). Děkuji.

[cmuch]

Když už jsem to udělal tak sem taky dám.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim rngSlouceni As Object
 Dim rngZdroj As Object
 
 Set rngZdroj = Range("B2")
 Set rngSlouceni = rngZdroj.Offset(0, 1).Resize(6, 1)
 
 If Target.Address = rngZdroj.Address Then

  Application.DisplayAlerts = False
 
  If rngZdroj = 1 Then
    With rngSlouceni
     .UnMerge
     .Merge
     .FormulaLocal = "=B2"
    End With
  ElseIf rngZdroj = 2 Then
    With rngSlouceni
     .UnMerge
     .Resize(3, 1).Merge
     .Offset(3, 0).Resize(3, 1).Merge
     .FormulaLocal = "=B2"
    End With
  ElseIf rngZdroj = 3 Then
    With rngSlouceni
     .UnMerge
     .Resize(2, 1).Merge
     .FormulaLocal = "=B2"
     .Offset(2, 0).Resize(2, 1).Merge
     .FormulaLocal = "=B2"
     .Offset(4, 0).Resize(2, 1).Merge
     .FormulaLocal = "=B2"
    End With
  End If
 
  Application.DisplayAlerts = True

  With rngSlouceni
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
  End With
 End If
End Sub



[Račis]

I druhý způsob je výborný :). Ale teď další "problém:

toto macro vyřeší jednu sestavu - to jsem upravil pro několik sloupců v jednom řádku, a výsledné macro i se vzorci je na XXX řádků (velmi velké). Je možnost macro přetahnout jako vzoreček? Straší mě představa, že mám 30x12 sestav (za jednu sestavu beru váš příklad), takže bych macro musel upravit pro 360sestav zvlášt (upravit oblasti buněk)

[Azuzula]

No, jako kopírování vzorce to nebude, ale upravila jsem to makro aby bylo univerzální. Jediné co je potřeba, je jeden pomocný sloupec nalevo od sloupce kam chceš zapisovat ty čísla podle kterých se budou slučovat buňky, do něho je potřeba napsat písmeno "x". Líp to teď nevymyslím, možná že někdo přijde ještě na lepší způsob.

Tady je makro nebo v příloze ukázka

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Cells.Count > 1 Then End 'ošetřuje chybu při mazání více buněk najednou
If Not Intersect(Target, Range("B:B")) Is Nothing Then 'provedení pouze ve sloupci B
    If Target.Offset(0, -1) = "x" Then 'kontrola znaku pro spuštění sloučení buněk
        Application.DisplayAlerts = False
        If Target = 1 Then
            Set rng = Range(Target.Offset(0, 1), Target.Offset(5, 1))
            slouceni rng
            Target.Offset(0, 1).FormulaLocal = "=1+1" 'vzorec do sloučené buňky
        ElseIf Target = 2 Then
            Set rng = Range(Target.Offset(0, 1), Target.Offset(2, 1))
            slouceni rng
            Set rng = Range(Target.Offset(3, 1), Target.Offset(5, 1))
            slouceni rng
            Target.Offset(0, 1).FormulaLocal = "=1+1" 'vzorec do sloučené buňky
            Target.Offset(3, 1).FormulaLocal = "=2+1" 'vzorec do sloučené buňky
        ElseIf Target = 3 Then
            Set rng = Range(Target.Offset(0, 1), Target.Offset(1, 1))
            slouceni rng
            Set rng = Range(Target.Offset(2, 1), Target.Offset(3, 1))
            slouceni rng
            Set rng = Range(Target.Offset(4, 1), Target.Offset(5, 1))
            slouceni rng
            Target.Offset(0, 1).FormulaLocal = "=1+1" 'vzorec do sloučené buňky
            Target.Offset(2, 1).FormulaLocal = "=2+1" 'vzorec do sloučené buňky
            Target.Offset(4, 1).FormulaLocal = "=3+1" 'vzorec do sloučené buňky
        End If
        Application.DisplayAlerts = True
    End If
End If
End Sub
Private Sub slouceni(rng As Range)
With rng
'sloučí buňky
    .MergeCells = False
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
'nakreslí okraje
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End With
End Sub

[Račis]

Jejda, to už vypadá velmi složitě . Alu jdu se do toho položit, abych to pochopil, a pak pošlu kytku s bonbonierou :).

EDIT1:

oki, po nějaké době jsem pochopil jak přidávat buňky další oblasti v řadě . Ale teď, když chci do "Target.Offset(0, 1).FormulaLocal = """ " napsat vzorec "=SUMIF(ROZPOČET!D:D;'PLÁN VŘ'!G14:G19;ROZPOČET!J:J), musím oblast pro kritérium, která je v tuhle chvíli vyjádřena jako pevná hodnota 'PLÁN VŘ'!G14:G19, výjádřit taky nějak obecně?

Vlastne chci, aby když se mi po sobě změní za sebou v mém případě 12 oblastí, tak aby se mi doplnil do oblasti (třeba třetí) vzoreček, který bere hodnotu z druhé (viz příklad).

(to bude muset být jedna kytka a hodně bonboniér )

[Azuzula]

Chtělo by to trochu přesnější příklad, takhle z toho nepoznám co vlastně potřebuješ a kde je ta oblast PLÁN VŘ'!G14:G19 resp. kde bude relativně ke každé buňce se vzorcem. Možná bude třeba pozměnit i strukturu listu aby to šlo udělat univerzálně a nebo to napsat růčo pro celý sešit, nevím.

Máš už nějakou strukturu sešitu hotovou? Potřebovala bych ostrý dokument (klidně s dummy daty) s ukázkou jak si to představuješ aby jsme se vyhnuli teoriím a pracovali na něčem reálným.

PS: miluju hořkou čokoládu :)

[Račis]

Do PM jsem poslal vzor :)

jestli to chápu správně, tak se v první části oblast pojmenuje "rng", a v další se sloučí. Potřebuji teda ve vzorečku nahradit "PLÁN VŘ'!G14:G19" určitou RNG.

Nvm jestli jdu vůbec správným směrem. Budu muset koupit nějakou učebnici a nastudovat , nemám s tím žádné zkušenosti :/.

[Azuzula]

ten "PLÁN VŘ'!G14:G19" jde nahradit odkazem na jedinou buňku tedy "G14" protože se nachází ve stejném listu a je první ve sloučené oblasti buněk. V PM jsem poslala "trošku" předělané makro aby fungovalo univerzálně, bylo co nejmenší, snadno upravitelné a stačilo jen měnit vzorce

PS: Kdyby někdo potřeboval podobné makro, jde použít to už zveřejněné, teď už přes PM ladíme procedury na další požadavky a na mnohem větší rozsahy dat.