XL 2019 Copier / Coller

[Tioneb_h]

Bonjour, je voudrais copier toutes les cellules déverrouillées non contiguës d’une feuille de calcul avec un bouton et coller les valeurs des cellules vers une autre feuille de calcul (autre fichier), MAIS à la même place ! Avec : Ctrl V
Quelqu’un peut m’aider ?
Merci d’avance pour votre aide
Ben

 

[Robert]

Bonsoir Tioneb, bonsoir le forum,

Peut_être comme ça (à adapter) :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set OS = Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD (à adapter à ton cas)
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.Copy OD.Range(CEL.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

 

[patricktoulon]

Bonjour
si c'est seulement les valeurs qui sont souhaitées
pas besoins de copier
on compile la plage avec union
puis feuil2 meme address=la plage

Sub test()
    Dim p As Range, p2 As Range
    Set p = Feuil1.UsedRange

    For Each cel In p.Cells
        If cel.Locked = False Then If p2 Is Nothing Then Set p2 = cel Else Set p2 = Union(p2, cel)
    Next
    Feuil2.Range(p2.Address) = p2
End Sub

 

[Tioneb_h]

Bonsoir Tioneb, bonsoir le forum,

Peut_être comme ça (à adapter) :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set OS = Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD (à adapter à ton cas)
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.Copy OD.Range(CEL.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

bonjour,

Je viens de faire le test... et ça fonctionne sur le même classeur

Comment est-ce que l'on peut faire pour avoir la même chose d'un classeur1 ("Feuil1") à une autre calsseur2 ("Feuil1") ?

les noms des classeurs ne sont pas fixes...
exemples :
22-01-12 Calcul devis XXX_TSC.xlsm
22-02-09 Calcul devis XXX_BHE.xlsm

Ben

 

[patricktoulon]

Bonjour
Je ne suis pas sur que copy destination fonctionne sur deux classeurs( je peux me tromper)
tester alors copy puis selection classeur 2,feuille destination , range de destination puis paste et paste specialformat si l'on veux garder les formats
si le format n'est pas une donnée de l’équation alors un simple value=value fait l'affaire
exemple
workbooks("classeur2.xlsm").feuil1.range("A1:F10").value=thisworkbook.feuil1.range("C3:H13").value

 

[Robert]

Bonsoir le fil, bonsoir le forum,

Essaie comme ça. Code à mettre dans le classeur source :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As FileDialog 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = ThisWorkbook 'définit la classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
Set F = Application.FileDialog(msoFileDialogOpen) 'définit le fichier F (à l'aide de la boîte de dialogue [Ouvrir])
F.Show 'affiche la boîte de dialogue
If F.SelectedItems.Count > 0 Then 'condition si au moins un fichier est sélectionné
    Workbooks.Open (F.SelectedItems(1)) 'ouvre le fichier sélectionné
Else 'sinon
    Exit Sub 'sort de la procédure
End If
Set CD = ActiveWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Feuil1") 'définit l'onglet destination OD
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.Copy OD.Range(CEL.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

 

[Tioneb_h]

Bonsoir le fil, bonsoir le forum,

Essaie comme ça. Code à mettre dans le classeur source :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As FileDialog 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = ThisWorkbook 'définit la classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
Set F = Application.FileDialog(msoFileDialogOpen) 'définit le fichier F (à l'aide de la boîte de dialogue [Ouvrir])
F.Show 'affiche la boîte de dialogue
If F.SelectedItems.Count > 0 Then 'condition si au moins un fichier est sélectionné
    Workbooks.Open (F.SelectedItems(1)) 'ouvre le fichier sélectionné
Else 'sinon
    Exit Sub 'sort de la procédure
End If
Set CD = ActiveWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Feuil1") 'définit l'onglet destination OD
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.Copy OD.Range(CEL.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

Bonjour,

Encore merci pour votre retour rapide
J'ai une erreur 400 ?
Je vous ai joint les deux fichiers pour exemple... copier le classeur1 dans le classeur 2.

encore merci,
Ben

 

[Tioneb_h]

je me demande si ce n'est pas parce que j'ai des formules avec "test logique" dans des cellules verrouillées que j'ai une erreur 400 ?

 

[Tioneb_h]

bonjour,

j'ai trouvé pourquoi j'ai une erreur 400... c'est parce que j'ai des cellules fusionnées !

est-ce qu'il y a moyen de changer le code pour copier/coller des cellules fusionnées vers d'autres cellules fusionnées de l'autre fichier ?

j'espère que votre savoir faire va pouvoir m'aider

Ben

 

[Robert]

Bonjour Benoit, bonjour le forum,

D'abord il faut que tu saches que VBA et les cellules fusionnées ne sont pas amis du tout. D'autant plus que la conception de tes fichiers ne nécessitait pas de cellules fusionnées. À l'avenir pense VBA => pas de cellules fusionnées... Pense aussi que si tu avais joint les fichiers dès ton premier post on n'aurait pas perdu de temps...
Tu as placé le code dans les deux fichiers !... Est-ce vraiment nécessaire ? Normalement il aurait dû être placé uniquement dans le fichier source et pas dans un composant Worksheet comme Feuil1 (METRE), mais dans un module standard comme Module1. Mais ça, ce n'était pas ce qui causait le bug.
Le code modifié :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As FileDialog 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = ThisWorkbook 'définit la classeur source CS
Set OS = CS.Worksheets("METRE") 'définit l'onglet source OS
Set F = Application.FileDialog(msoFileDialogOpen) 'définit le fichier F (à l'aide de la boîte de dialogue [Ouvrir])
F.Show 'affiche la boîte de dialogue
If F.SelectedItems.Count > 0 Then 'condition si au moins un fichier est sélectionné
    Workbooks.Open (F.SelectedItems(1)) 'ouvre le fichier sélectionné
Else 'sinon
    Exit Sub 'sort de la procédure
End If
Set CD = ActiveWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("METRE") 'définit l'onglet destination OD
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.MergeArea.Copy OD.Range(CEL.MergeArea.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

Le fichier source :

 

[Tioneb_h]

Bonjour Benoit, bonjour le forum,

D'abord il faut que tu saches que VBA et les cellules fusionnées ne sont pas amis du tout. D'autant plus que la conception de tes fichiers ne nécessitait pas de cellules fusionnées. À l'avenir pense VBA => pas de cellules fusionnées... Pense aussi que si tu avais joint les fichiers dès ton premier post on n'aurait pas perdu de temps...
Tu as placé le code dans les deux fichiers !... Est-ce vraiment nécessaire ? Normalement il aurait dû être placé uniquement dans le fichier source et pas dans un composant Worksheet comme Feuil1 (METRE), mais dans un module standard comme Module1. Mais ça, ce n'était pas ce qui causait le bug.
Le code modifié :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As FileDialog 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CEL As Range 'déclare la variable CEL (CELlule)

Set CS = ThisWorkbook 'définit la classeur source CS
Set OS = CS.Worksheets("METRE") 'définit l'onglet source OS
Set F = Application.FileDialog(msoFileDialogOpen) 'définit le fichier F (à l'aide de la boîte de dialogue [Ouvrir])
F.Show 'affiche la boîte de dialogue
If F.SelectedItems.Count > 0 Then 'condition si au moins un fichier est sélectionné
    Workbooks.Open (F.SelectedItems(1)) 'ouvre le fichier sélectionné
Else 'sinon
    Exit Sub 'sort de la procédure
End If
Set CD = ActiveWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("METRE") 'définit l'onglet destination OD
For Each CEL In OS.UsedRange 'boucle sur toutes les cellules CEL de la plage éditée de l'onglet OS
    'si la cellule est déverrouillée, copy la cellule dans l'onglet OD à la même adresse
    If CEL.Locked = False Then CEL.MergeArea.Copy OD.Range(CEL.MergeArea.Address)
Next CEL 'prochaine celllue de la boucle
End Sub

Le fichier source :

Bonjour,
Désolé pour les allers/retours... tout fonctionne.
Merci pour votre savoir-faire.
Ben

 

[Tioneb_h]

Bonjour,

Je suis super contant pour la Macro... ça fonctionne super bien et me fait gagner beaucoup de temps dans mes transferts de calcul.

J'ai encore une idée pour aller plus vite dans le copier/coller d'un fichier à l'autre... (si possible) : est-ce que la VBA peut "verrouiller" toutes les cellules vides qui sont "déverrouillées" avant de faire le copier/coller ? ça limiterait le nombre de cellules à checker ?

Pour info, j'ai au total dans mon ficher 5340 cellules déverrouillées...

Merci d’avance pour votre aide,
Ben

 

[Tioneb_h]

bonjour,

je n'ai pas eu de réponse à mon message ci-avant du 4 mars... je voudrais savoir si c'est possible ou pas.

Encore merci pour votre aides,
Ben

 

[Staple1600]

Bonjour

Oui, c'est possible
L'enregistreur de macros peut même te mettre sur la piste
Je te laisse essayer avant de publier ici ce que mon enregistreur aura pondu comme code VBA.

 

[Staple1600]

Re

Pour t'éviter de te fatiguer, voila de quoi faire le test toi-même sur une feuille vierge d'un classeur vide.
Lances d'abord cette macro: Creer_Test
(elle ne sert qu'à créér un exemple)

Puis lances la macro: Verouiller_Cellules_Vides

Tu verras que les cellules vides seront verrouillées.
NB: J'ai mis en jaune les cellules vides juste pour les trouver facilement
(cela ne sert que pour le test)

Sub Creer_Test()
Dim formule$, rng As Range: Set rng = Range("A1:J30")
formule = "=CHOOSE(RANDBETWEEN(1,5),CHAR(RANDBETWEEN(65,90)),INT(ROW()*NOW()/1600),11,"""",33)"
Application.ScreenUpdating = False
rng.Formula = formule: rng = rng.Value: rng.Locked = 0
End Sub
Sub Verouiller_Cellules_Vides()
Range("A1:J30").SpecialCells(xlCellTypeBlanks).Locked = True
' ligne ci-dessous pour test
Range("A1:J30").SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
End Sub