VBA en merged cells, cellenbereik aanpassen

[richard1970]

Hoi,

Een klant van ons heeft een Excelgedrocht gemaakt en daarin moeten de waarden van samengevoegde cellen gekopieerd worden naar andere samengevoegde cellen.
Het lukt me wel dit in VBA te zetten door eerst de samenvoeging er af te halen en er later weer op te zetten, maar ik hoop dat het stukken eenvoudiger kan. Voor één bereik heb ik:

Sub RM_merge_cells()
    With Selection
        .ShrinkToFit = True
        .MergeCells = True
    End With
End Sub

Sub RM_unmerge_cells()
    With Selection
        .ShrinkToFit = False
        .MergeCells = False
    End With
End Sub

Sub RM_copy_merged_cells()
Application.ScreenUpdating = False
    Range("[COLOR="red"]V39:AB42[/COLOR]").Select
        Call RM_unmerge_cells
    Range("C39:I42").copy
    Range("[COLOR="red"]V39[/COLOR]").PasteSpecial paste:=xlPasteValues
    
    Range("[COLOR="red"]V39:AB39[/COLOR]").Select
        Call RM_merge_cells
    Range("[COLOR="red"]V40:AB40[/COLOR]").Select
        Call RM_merge_cells
    Range("[COLOR="red"]V41:AB41[/COLOR]").Select
        Call RM_merge_cells
    Range("[COLOR="red"]V42:AB42[/COLOR]").Select
        Call RM_merge_cells
Application.ScreenUpdating = True

End Sub

De uitdaging zit 'm in het aanpassen van de rode bereiken. Na V39:AB42, komen er nog AO39:AU39, BH39:BN42 en CA39:CG42. (Telkens 19 kolommen naar rechts). Dit staat in de derde subroutine.
Vervolgens wordt dit riedeltje herhaald voor de rijen 82:85, 125:128 en telkens 43 rijen verder naar beneden tot aan rij 1071, telkens ook weer 19 kolommen naar rechts.

Ik heb al geadviseerd de samenvoeging er af te halen, maar dat moet er per se op omdat de invoer te lang kan worden maar wel leesbaar geprint moet kunnen worden.
De handelingen zijn erg gestructureerd, maar ik heb niet de kennis om in VBA er een loop van te maken.
Is dat wel mogelijk?

Richard

 

[Niels28]

Kan het niet test maar is dit wat je zoekt?

Sub RM_copy_merged_cells()
Application.ScreenUpdating = False
For rw = 39 To 1071 Step 43
For kl = 22 To 79 Step 19

    'Range("V39:AB42").Select
 Range(Cells(rw, kl), Cells(rw + 3, kl + 6)).Select
        Call RM_unmerge_cells
    'Range("C39:I42").Copy
  Range(Cells(rw, 3), Cells(rw + 3, 9)).Copy
    'Range("V39").PasteSpecial Paste:=xlPasteValues
    Cells(rw, kl).PasteSpecial Paste:=xlPasteValues
    
    'Range("V39:AB39").Select
     Range(Cells(rw, kl), Cells(rw, kl + 6)).Select
        Call RM_merge_cells
    'Range("V40:AB40").Select
         Range(Cells(rw + 1, kl), Cells(rw + 1, kl + 6)).Select
        Call RM_merge_cells
    'Range("V41:AB41").Select
      Range(Cells(rw + 2, kl), Cells(rw + 2, kl + 6)).Select
        Call RM_merge_cells
    'Range("V42:AB42").Select
    Range(Cells(rw + 3, kl), Cells(rw + 3, kl + 6)).Select
        Call RM_merge_cells
        Next kl
        Next rw
        
Application.ScreenUpdating = True

End Sub

Niels

 

[richard1970]

Beste Niels,

Helemaal TOP! Ik heb het getest en het werkt.
Ik kan jouw macro nu aanpassen voor overige tabbladen met een afwijkend aantal regels.

Bedankt!

Richard

 

[Niels28]

Graag gedaan,

Hij kan trouwens nog korter.

Sub RM_copy_merged_cells()
Application.ScreenUpdating = False

For rw = 39 To 1071 Step 43
    For kl = 22 To 79 Step 19
        Range(Cells(rw, kl), Cells(rw + 3, kl + 6)).Select
        Call RM_unmerge_cells
        Range(Cells(rw, 3), Cells(rw + 3, 9)).Copy
        Cells(rw, kl).PasteSpecial Paste:=xlPasteValues
            For x = 0 To 3
                Range(Cells(rw + x, kl), Cells(rw + x, kl + 6)).Select
                Call RM_merge_cells
            Next x
    Next kl
Next rw
Application.ScreenUpdating = True
End Sub

Niels

 

[Ginger]

Richard, ik kan niet helemaal achterhalen hoe het kopieren en plakken nou zit in die code van je (dus Niels28, mijn complimenten!!!), maar MOET het perse met Copy/Paste? Als je alléén maar een waarde hoeft over te zetten, kan dat óók rechtstreeks...
Even als voorbeeld: Het bereik D6:F6 is samengevoegd. De waarde moet worden overgezet naar het samengevoegde bereik I6:K6. In VBA zeg je dan heel simpel...

Range("I6").Value = Range("D6").Value

...en klaar ben je. Dit kan je natuurlijk voor je lus ook doen met het object Cells ipv Range.

Of denk ik nu te simpel???

Groet, Leo

 

[richard1970]

GRMBL, kijk dat heb je nou als je geen deskundige bent in VBA. Ik begin doorgaans met de macrorecorder mijn handelingen op te nemen en ga dan in de VBA-editor de code opschonen, aanpassen en -als het lukt- variabel maken. Maar kopiëren en plakken lukte al niet, dus zocht ik een manier om het wel voor elkaar te krijgen (dus samenvoegen verwijderen en er weer op zetten) en daarop heeft Niels weer verder geborduurd.
Ik ga eens kijken of ik jouw voorstel kan combineren met Niels' code.

Groeten,
Richard

 

[Ginger]

Ik ga eens kijken of ik jouw voorstel kan combineren met Niels' code.

Ik wil je d'r best mee helpen maar dan zal je me toch echt een bijlage moeten geven zodat ik snap WAT er nou eigenlijk waar naar toe moet worden gekopieerd. Want dit kan mijn kleine begrijpertje zo niet aan...

Groet, Leo

 

[richard1970]

Dat wordt dan morgen of donderdag want de Citrixserver ligt plat. Ik kan dus niet inloggen op mijn werk. :-(

 

[Niels28]

Zonder copy/paste, net zoals vorig voorbeeld kan ik het zonder bestand niet testen.

Sub RM_copy_merged_cells()
Application.ScreenUpdating = False
For rw = 39 To 1071 Step 43
    For kl = 22 To 79 Step 19
        Range(Cells(rw, kl), Cells(rw + 3, kl)) = Range(Cells(rw, 3), Cells(rw + 3, 3)).Value
    Next kl
Next rw
Application.ScreenUpdating = True
End Sub

Niels

 

[richard1970]

Hoi Niels,

Was even te druk zo om te testen afgelopen week. Ik heb het nu getest en het werkt prima!
Merçi.

Groeten,
Richard