Copier des colonnes discontinues en VBA avec un ordre

Le 08/07/2022 à 16:56

Bonjour à tous,

Je cherche à sélectionner certaines colonnes d'un classeur "maitre" et les coller dans un autre classeur "visites médicales". Ce classeur "maitre" verra de nouvelles données arriver régulièrement. Le programme de copie du classeur "visites médicales"

devra donc pouvoir récupérer les nouvelles entrées sans écraser les anciennes.

Mais je bute sur certaines difficultés :

  • mon ordre de sélection des colonnes n'est pas respecté dans la copie
  • j'aimerais que les lignes s'ajoutent au fur et a mesure sans doublons

Pour l'instant j'arrive à copier ces données à l'aide de plusieurs instruction de copy pour respecter l'ordre mais j'écrase sans cesse mes données.

A ce stade mon code ressemble à ça après de nombreuses tentatives.

Je suis donc preneur d'idées de code pour finaliser mon projet.

Merci d'avance

Sub recuperer_donnees()

    'Déclaration des variables
    Dim MonClasseur As Workbook
    Dim DL As Long

    'On désactive le presse-papier et le rafraichissement de l'écran
    Application.CutCopyMode = False
    Application.ScreenUpdating = False

    Set MonClasseur = Application.Workbooks.Open("C:\Users\beaugenj53r\Documents\Document maitre\master.xlsx")
    MonClasseur.Activate

    DL = MonClasseur.Sheets("maitre").[A65536].End(xlUp).Row

   'On copie les données de la feuille du classeur sélectionné, seules les colonnes A,B,C,D,F,W,X,S,T,Y,V,K,N du document maitre m’intéressent et dans cet ordre
    MonClasseur.Sheets("maitre").Range("A2:D" & DL & ",F2:F" & DL).Copy
   'On colle les données dans la feuille active
    ThisWorkbook.ActiveSheet.Range("A3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("W2:X" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("F3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("S2:T" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("H3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("Y2:Y" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("J3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("V2:V" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("K3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("K2:K" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("L3").PasteSpecial xlPasteValues

    MonClasseur.Sheets("maitre").Range("N2:N" & DL).Copy
    ThisWorkbook.ActiveSheet.Range("M3").PasteSpecial xlPasteValues 

    'On désactive les messages d'alerte
    Application.DisplayAlerts = False

    'On ferme le classeur source
    MonClasseur.Close

    'On réactive le presse-papier et le rafraichissement de l'écran
    Application.CutCopyMode = True
    Application.ScreenUpdating = True    

End Sub
Le 08/07/2022 à 18:17

Bonjour Jej et bienvenu, bonjour le forum,

Peut-être comme ça (à compléter en adaptant) :
Sub recuperer_donnees()
Dim CD As Workbook
Dim OD As Worksheet
Dim CS As Workbook
Dim OS As Worksheet
Dim DL As Long
Dim PL As Long

Application.ScreenUpdating = False
Set CD = ThisWorkbook
Set OD = CD.ActiveSheet
Set CS = Application.Workbooks.Open("C:\Users\beaugenj53r\Documents\Document maitre\master.xlsx")
Set OS = CS.Worksheets("maitre")
DL = OS.cells(Application.Rows.Count, "A").End(xlUp).Row
PL = IIf(OD.Range("A3").Value <> "", 3, OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1)

'******************************************
'partie à répéter en l'adaptant au colonnes
OS.Range("A2:D" & DL & ",F2:F" & DL).Copy
OD.Cells(PL, "A").PasteSpecial xlPasteValues
'******************************************

CS.Close False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Le 11/07/2022 à 11:30

Merci pour cette réponse ultra rapide.

J'ai fait les modifications dans mon code. Le nouveau programme est plus court et plus élégant que le mien.

Le programme tourne bien et affiche les données les unes à la suite des autres. C'est top! Merci beaucoup.

Je cherche maintenant à ce que le programme ne copie ou n'affiche que les nouvelles données sans prendre en compte les anciennes déjà importées.

Le 11/07/2022 à 19:22

Re,

Si tu avais eu la brillante idée de mettre en pièce jointe le fichier source, j'aurais pu te faire une proposition. Il faut rajouter un marqueur pour que la macro reconnaisse les lignes déjà importées...

Le 12/07/2022 à 09:26

Bonjour voici le fichier source avec des données fictives.

11maitre.xlsx (17.63 Ko)
Le 12/07/2022 à 11:27

Bonjour,

J'ai rajouté une colonne à la fin du tableau (AE) nommée Marqueur.

Le code à compléter et à adapter :

Sub recuperer_donnees()
Dim CD As Workbook
Dim OD As Worksheet
Dim CS As Workbook
Dim OS As Worksheet
Dim DL As Long
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim PL As Long
Dim PM As Range 'déclare la variable PM (Plage du Marqueur)
Dim I As Integer 'déclarfe la variable I (Incrément)

Application.ScreenUpdating = False
Set CD = ThisWorkbook
Set OD = CD.ActiveSheet
Set CS = Application.Workbooks.Open("C:\Users\beaugenj53r\Documents\Document maitre\master.xlsx")
Set OS = CS.Worksheets("maitre")
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
PL = IIf(OD.Range("A3").Value <> "", 3, OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1)

'******************************************
'première partie
For I = 2 To DL 'boucle sur toutes les lignes I du tableau de valeurs TV
    If TV(I, 31) = "" Then 'conditionn 1 : si la donnée ligne I colonne 31 (=> colonne AE) est vide
        If PM Is Nothing Then 'condition 2 : si PM est vide
            Set PM = OS.Range(OS.Cells(I, "A"), OS.Cells(I, "D")) 'définit PM (une seule ligne)
        Else 'sinon
            Set PM = Application.Union(PM, OS.Range(OS.Cells(I, "A"), OS.Cells(I, "D"))) 'définit PM en ajoutant une ligne à chaque boucle
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle
If Not PM Is Nothing Then 'condition : si PM n'est pas vide
    PM.Copy 'copie la plage PL
    OD.Cells(PL, "A").PasteSpecial xlPasteValues 'colle les valeurs
    PM.Columns(31).Value = "X" 'écrit le marque (X) dans la colonne 31
Else
    Goto fin
End If 'fin de la condition
'******************************************

'suite
Set PM = PM.Resize(PM.Rows.Count, 2).Offset(0, 22) 'on redéfinit PM (deux colonnes déclalées de 22 colonnes à droite = W:X)
PM.Copy
OD.Cells(PL, "F").PasteSpecial xlPasteValues 'colle les valeurs dans la colonne F

Set PM = PM.Offset(0, -4) 'on redéfinit PM (toujours deux colonne décalées de 4 colonne vers la gauche = S:T)
PM.Copy
OD.Cells(PL, "H").PasteSpecial xlPasteValues 'colle les valeurs dans la colonne H

Set PM = PM.Resize(PM.Rows.Count, 1).Offset(0, 6) 'on redéfinit PM (une seule colonne décalée de 6 colonne à droite = Y)
PM.Copy
OD.Cells(PL, "J").PasteSpecial xlPasteValues 'colle les valeurs dans la colonne Y

'etc, etc... je te laisse le soin de finir sur le même principe...

fin:'étiquette
CS.Close False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Rechercher des sujets similaires à "copier colonnes discontinues vba ordre"