Meerdere cellen kopieren met VBA

[rk1]

Hallo,

ik heb een code gevonden waarbij ik met 1 druk op de knop, verschillende cellen kan selecteren.
Deze code wil ik opbouwen zodat ik verschillende cellen kan kopieren.
Zodat ik deze vervolgens in het basisbestand kan plakken.
Kan iemand me hierbij helpen?

Private Sub CommandButton1_Click()

    Range("A1:B2,A15:A22,B10:H75").Select
    Dim rng
    Set rng = Selection
    Debug.Print rng.Address

End Sub

 

[HSV]

Met zoiets.

Sub hsv()
Dim area As Range, sRng As Range
 For Each area In Sheets(1).Range("A1:B2,A15:A22,B10:H75").Areas
   Set sRng = area
sRng.Copy Sheets(2).Range(sRng.Address)
   Next area
End Sub

Onderstaande kopieert niet, maar zet alleen de waarden.

Sub hsvtwee()
Dim area As Range, sRng As Range
 For Each area In Sheets(1).Range("A1:B2,A15:A22,B10:H75").Areas
   Set sRng = area
 Sheets(2).Range(sRng.Address) = sRng.Value
   Next area
End Sub

 

[rk1]

Het is de bedoeling dat er tekst wordt gekopieerd uit een invulbestand (deze is in opmaak gelijk aan het basisbestand) en het gekopieerde deel moet vastgehouden worden. Als ik vervolgens het basisbestand open dan moet hij het gekopieerde deel plakken over het bestand (bijv. m.b.v. ctrl-V)
Dit basisbestand is beveiligd dus moet hij alleen de tekst kopieren uit de cellen die niet beveiligd zijn. Zo denk ik de beveiliging te omzeilen.

Als ik je code een beetje aanpas (zie hieronder), dan kopieert hij alleen de cellen B10:H75.
Ik wil dus graag dat hij alle verschillende bereiken kopieert.

Private Sub CommandButton1_Click()

Dim area As Range, sRng As Range
 For Each area In Sheets(1).Range("A1:B2,A15:A22,B10:H75").Areas
   Set sRng = area
sRng.Copy
   Next area

End Sub

 

[HSV]

Als je het klembord opent, staan ze er allemaal in.

 

[Willem99]

Maar je kunt geen bereik plakken over een beveiligd werkblad.

Ik wil dat er verschillende onbeveiligde bereiken worden gekopieerd dmv een druk op een knop.
En dat ik deze vervolgens plak over het beveiligde basisbestand (waarbij dezelfde cellen niet zijn beveiligd, maar dus nog leeg zijn..)

 

[HSV]

Wie is nu weer "ik" ?

 

[rk1]

ow foutje, stond ingelogd onder de naam van mijn broertje.

 

[Warme bakkertje]

Open in dezelfde code dan je basisbestand, plak daar de bereiken in, sluit je basisbestand terug af met behoud van de wijzigingen.

Sub hsvtwee()
    Dim area As Range, sRng As Range
    Workbooks.Open "Volledig pad naar basisbestand" 'aanpassen naar juiste situatie
    For Each area In ThisWorkbook.Sheets(1).Range("A1:B2,A15:A22,B10:H75").Areas
        Set sRng = area
        ActiveWorkbook.Sheets(1).Range(sRng.Address) = sRng.Value
    Next area
    ActiveWorkbook.Close True
End Sub

 

[rk1]

Ik heb de code toegevoegd. Het bestand word geopend en hij kopieert het onderstreepte bereik. Hij geeft een foutmelding (fout 1004) bij de dikgedrukte regel hieronder. Bij beide bestanden gaat het om het 1e sheet, en deze hebben beide dezelfde naam. Gaat het hier fout?
Bovendien kopieert hij alleen het onderstreepte bereik, het eerste deel dus. De andere 2 bereiken pakt hij niet..

hsvtwee()
    Dim area As Range, sRng As Range
    Workbooks.Open "deze heb ik goed toegevoegd"
For Each area In ThisWorkbook.Sheets(1).Range("[U]C2:G10[/U],C15:C22,E15:E22").Areas
        Set sRng = area
[B]        ActiveWorkbook.Sheets(1).Range(sRng.Address) = sRng.Value[/B]    
Next area
    ActiveWorkbook.Close True
End sub

 

[Warme bakkertje]

Zitten er ergens samengevoegde cellen tussen, want bij mij werkt dit perfect ?

 

[HSV]

Voor als er beveiligde cellen tussen zitten.

Sub hsv()
Dim area As Range, sRng As String, cl As Range
 For Each area In Sheets(1).Range("A1:B2,A15:A22,B10:H75").Areas
For Each cl In area
   If cl.Locked = False Then
       sRng = cl.Address
       Sheets(2).Range(sRng) = Sheets(1).Range(sRng).Value
      End If
   Next cl
 sRng = ""
   Next area
End Sub

 

[rk1]

Ik heb de 2 bestandjes toegevoegd aan de bijlage.
Bestandje 1=test1.xlsm, hier vul je de waardes in en vervolgens druk je op de kopieerknop

Hij opent nu bestandje 2 (dit is ook de bedoeling, dit bestandje moet niet al geopend zijn!)

Bestandje 2=test1 basisbestand.xlsm, hier dient hij de juiste waardes uit test1.xlsm te plakken.

Beide pagina's zijn beveiligd, code is niet ingevuld (enter)

Ik heb de laatste code van HSV toegepast en deze gecombineerd met de code warme bakkertje.
Alleen werkt hij nog niet helemaal. Het kopieren gaat nog niet..

Bekijk bijlage test1.xlsm
Bekijk bijlage test1 basisbestand.xlsm

PS: let bij het opslaan of de vba-code de juiste verwijzing naar desktop heeft.

 

[Warme bakkertje]

Private Sub CommandButton1_Click()

    Dim area As Range, cl As Range
    Workbooks.Open "C:\Users\Desktop\test1 basisbestand.xlsm" 'aanpassen naar juiste situatie
    For Each area In ThisWorkbook.Sheets(1).Range("B1:B3,C6:C11,H1").Areas
        For Each cl In area
            If cl.Locked = False Then
                ActiveWorkbook.Sheets(1).Range(cl.Address) = ThisWorkbook.Sheets(1).Range(cl.Address).Value
            End If
        Next cl
    Next area
    ActiveWorkbook.Close True
    
End Sub

 

[rk1]

Dat is hem, bedankt hij werkt als een trein.
Ik heb alleen de regel ActiveWorkbook.Close True weggehaald.
Zo blijft mijn bestand openstaan en kan ik hem opslaan onder de juiste nieuwe naam.

 

[Warme bakkertje]

Zo blijft mijn bestand openstaan en kan ik hem opslaan onder de juiste nieuwe naam.

Dat kan je toch ook ineens in je code regelen.

 

[rk1]

Dat kan inderdaad, maar het bestand moet nog gecontroleerd en evt bewerkt worden. Vandaar dat ik een opslaan als knop erbij heb gemaakt.