Selectionner un plage de valeur à partir d'une cellule avec texte précis

Le 11/07/2019 à 11:30

Bonjour,

moi voila de retour avec cette fois ci un peu de VBA.

Explication :

Je vais importer des données d'un fichier excel variable "Fichier A" (fichier excel créé après chaque mesure 3D) vers un fichier pour exploiter les données "Fichier B" .

Pour me facilter un peu et éviter trop de lien entre deux fichier, je souhaite récupérer une certaine plage de donnée du "fichier A" pour la coller dans mon "fichier B", le reste du trie se fera en rechercheV dans le meme fichier

Cependant cette plage de celle n'est pas toujours au même endroit.

Ma question est donc : Comment Faire pour une sélectionner une plage de valeur à partir d'une cellule contenant un texte précis.

A partir de la cellule contenant "Tableau d'entité géométrique"(se trouve dans la colonne A) il faut que les 36 prochaines lignes et les colonnes de A à F soit sélectionné.

Comment faire?

Désolé je ne pourrais pas mettre le fichier du rapport de mesures pour des raison de confidentialité, si c'est vraiment nécessaire je ferais un fichier exemple.

Merci d'avance pour votre aide

Le 11/07/2019 à 11:39

Bonjour,

  • Récuperer la cellule que tu recherche avec par exemple la fonction find.
  • Enfin, il suffit d'ajouter 36 à la ligne précédemment obtenu pour connaitre le numéro de la ligne de la fin de ta plage.

Si tu as des question, ne pas hésiter.

Cordialement

Le 11/07/2019 à 11:57

Bonjour le fil, bonjour le forum,

Il manque beaucoup de données ! Tu devras adapter le code ci-dessous. Code à mettre dans le fichier B :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD (à adapter à ton cas)
Set CS = Workbooks("Fichier A.xlsx") 'définit le classeur source CS (à adapter a ton cas)
Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).Find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST
End Sub
Le 11/07/2019 à 11:59

Bonjour,

Tu peux t'inspirer de cette macro

Sub Test()
Dim C As Range, MaPlage As Range
    Set C = Columns("A").Find("Tableau d'entité géométrique", , xlValues, xlPart)
    If Not C Is Nothing Then
        Set MaPlage = C.Offset(1).Resize(36, 6)
        MsgBox "La plage correspond à l'adresse " & MaPlage.Address(0, 0)
    End If
End Sub

Cordialement.

Le 11/07/2019 à 12:59

Merci à tous pour votre aide mais je n'y arrive toujours pas...

J'aurai du préciser que je n'ai peu voir aucune compétence en VBA...

Vince1512 :

Je ne peux pas faire juste avec la une sélection de cellule car ma cellule "Tableau d'entité géométrique" peut varier d'emplacement.

Il faut donc absolument que la cellule soit sélectionné si celle ci contient "Tableau d'entité géométrique"

ThauThème :

Je n'arrive pas à remplacer correctement les variables, très certainement des erreurs de manipulation de ma part

Gyrus :

Cette macro semble fonctionner mais à moitié, j'ai uniquement le message concernant la plage de valeur mais celle ci n'est pas sélectionné...

Le 11/07/2019 à 13:05

Re,

Je ne peux pas faire juste avec la une sélection de cellule car ma cellule "Tableau d'entité géométrique" peut varier d'emplacement.

La fonction find permet de localiser une cellule selon son contenu. Après si tu n'as aucune connaissance en VBA, je t'invite à aller lire un cours dessus (trouvable relativement facilement sur le net). Ça te permettra rapidement d'avoir un niveau suffisant pour comprendre la plus part des manipulations, ensuite il te manquera juste des notions d’algorithmie et des connaissances vis à vis des fonctions évitant de nombreuses lignes de codes inutiles.

Le 11/07/2019 à 13:09

effectivement j'ai pas fait attention à la formule Find,

Je vais chercher quelque cours sur le VBA afin de ne pas être largué car je dois finir ce fichier le plus tôt possible

Merci pour ton aide

Le 15/07/2019 à 09:58
gyrus a écrit :

Bonjour,

Tu peux t'inspirer de cette macro

Sub Test()
Dim C As Range, MaPlage As Range
    Set C = Columns("A").Find("Tableau d'entité géométrique", , xlValues, xlPart)
    If Not C Is Nothing Then
        Set MaPlage = C.Offset(1).Resize(36, 6)
        MsgBox "La plage correspond à l'adresse " & MaPlage.Address(0, 0)
    End If
End Sub

Cordialement.

Je reviens sur ce problème, cette macro marche très bien cependant cela m'indique seulement la plage mais ne la sélectionne pas.

Comment faire pour que la plage soit sélectionné et copié ?

si je rajoute .Select cela marche puis ça me met une erreur :"Erreur d'exécution '424': Objet requis"

MAJ 10:25 : C'est bon j'ai réussi à sélectionner et copier, à partir d'un même classeur sur un même onglet maintenant il faut que j'adapte à un fichier différent

Merci d'avance

Le 15/07/2019 à 10:37
ThauThème a écrit :

Bonjour le fil, bonjour le forum,

Il manque beaucoup de données ! Tu devras adapter le code ci-dessous. Code à mettre dans le fichier B :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD (à adapter à ton cas)
Set CS = Workbooks("Fichier A.xlsx") 'définit le classeur source CS (à adapter a ton cas)
Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).Find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST
End Sub

Je viens d'essayer mais je n'arrive pas à adapter, cela me met des messages d'erreur

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(Tampon) 'définit l'onglet destination OD (à adapter à ton cas)
Set CS = Workbooks("rapport RPF D OF 53119359.xlsx") 'définit le classeur source CS (à adapter a ton cas)
Set OS = CS.Worksheets(Feuil1) 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST
End Sub
Le 15/07/2019 à 11:01

Re,

Il manque des guillemets aux noms des onglets :

Set OD = CD.Worksheets("Tampon")
Set OS = CS.Worksheets("Feuil1")
Le 15/07/2019 à 11:24
ThauThème a écrit :

Re,

Il manque des guillemets aux noms des onglets :

Set OD = CD.Worksheets("Tampon")
Set OS = CS.Worksheets("Feuil1")

Merci,

mon problème ce déplace maintenant, à la ligne

Set CS = Workbooks("rapport RPF G OF53119339.xlsx") 'définit le classeur source CS (à adapter a ton cas)

Cela m'indique "l'indice n'appartient pas à la sélection"

MAJ : Erreur de ma part, en regardant un peu mieux on trouve, mon fichier est un .xls et non xlsx

Merci beaucoup pour ton aide, maintenant, comment je peux faire en sorte que le nom du fichier soit réccupérer à partir d'une cellule ?

Cellule E9 onglet "A saisir" Fichier B

Le 16/07/2019 à 08:56

Re,

je ne comprends pas. Récupérer (=ce nom existe dans la cellule) ou stocker (=mettre le nom dans la cellule) le nom du fichier. pour quoi faire ? Explique nous mieux s'il te plaît.

Le 16/07/2019 à 10:21

Merci beaucoup pour votre aide, je pense avoir réussi tout ce que je voulais faire, voici le code

Sub transfertdonnées()

Worksheets("A saisir").Select
NumOF = Range("E9").Value 'Vient récupérer le numéro d'OF
Workbooks.Open Filename:="V:\Mes documents\A320 NEO\Rapport RPF\Rapport RPF Excel\" & NumOF & ".xls"
'Ouvre le rapport en fonction du numéro d'OF récupérer

    Application.ScreenUpdating = False

Dim CD As Workbook 'déclare la variable CD (Classeur Destination (carte de controle))
Dim CS As Workbook 'déclare la variable CS (Classeur Source (rapport de mesures))
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

'Vient chercher la cellule contenant "Tableau d'identité géométrique" puis copie la selection des valeurs pour la coller dans l'onglet tampon

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Tampon") 'définit l'onglet destination OD (à adapter à ton cas)
Set CS = Workbooks("" & NumOF & "")  'définit le classeur source CS (à adapter a ton cas)
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).Find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST

    ActiveWorkbook.Close
    'ferme le rapport de mesures après la copie et collage des valeurs

Worksheets("A saisir").Select
DG = Range("E13").Value

If DG = "G" Then 'Si l'élément est un Gauche alors

Sheets("Copie Données").Select  'Copie des donnés concernant le RPF Gauche Extrados
    Range("B2:T2").Select
    Selection.Copy
    Sheets("GAUCHE Extrados (GE)").Select  'vient se positionner sur la feuille des valeurs gauche Extrados
    Range("A1").End(xlDown).Offset(1).Select 'Récupère la première cellule vide du tableau des valeurs
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'colle les valeurs

Sheets("Copie Données").Select  'Même étape que précédement pour la partie Intrados RPF Gauche
    Range("B5:S5").Select
    Selection.Copy
    Sheets("GAUCHE Intrados (GI)").Select
    Range("A1").End(xlDown).Offset(1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Else  'Si l'élément n'est pas un Gauche (ou si rien de marqué dans "E13")

Sheets("Copie Données").Select  'Copie des donnés concernant le RPF Droit Extrados
    Range("B12:T12").Select
    Selection.Copy
    Sheets("DROIT Extrados (DE)").Select  'vient se positionner sur la feuille des valeurs Droit Extrados
    Range("A1").End(xlDown).Offset(1).Select 'Récupère la première cellule vide du tableau des valeurs
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'colle les valeurs

Sheets("Copie Données").Select  'Même étape que précédement pour la partie Intrados RPF Droit
    Range("B9:S9").Select
    Selection.Copy
    Sheets("DROIT Intrados (DI)").Select
    Range("A1").End(xlDown).Offset(1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End If

Sheets("Tampon").Select            'Efface le contenu dans la feuille Tampon
        Range("A1:G36").Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("A saisir").Select          'Efface les données dans "information A saisir"
    Range("E12:E14").Select
    Selection.ClearContents
    Range("E15").Select
Sheets("A saisir").Select

   Application.ScreenUpdating = True

End Sub

Ce que je voulais faire c'était récupérer le nom dans la cellule car c'est le nom de mon fichier (ce nom est lui même créé à partir de plusieurs fichier)

Je pense avoir ce qu'il me faut, n'hésitez pas à me dire si vous voyer eds truc qui pourrait manquer ou alors des truc inutiles à enlever

Merci

Le 16/07/2019 à 15:07

Re,

La règle d'or en VBA c'est d'éviter autant que tu le peux les Select et autres Activate inutiles. Il ne font que ralentir l'exécution du code et sont source de plantage. Les conventions disent aussi de déclarer les variables en début de code. Cela permet à un autre utilisateur de repérer facilement les variables utilisées et de mieux lire ton code.

Le code Modifié :

Sub transfertdonnées()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination (carte de controle))
Dim CS As Workbook 'déclare la variable CS (Classeur Source (rapport de mesures))
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

Application.ScreenUpdating = False
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Tampon") 'définit l'onglet destination OD (à adapter à ton cas)
NumOF = Worksheets("A saisir").Range("E9").Value 'Vient récupérer le numéro d'OF
Set CS = Workbooks.Open("V:\Mes documents\A320 NEO\Rapport RPF\Rapport RPF Excel\" & NumOF & ".xls")
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).Find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST
CS.Close False
'ferme le rapport de mesures après la copie et collage des valeurs

DG = Worksheets("A saisir").Range("E13").Value
If DG = "G" Then 'Si l'élément est un Gauche alors
    Sheets("Copie Données").Range("B2:T2").Copy
    Sheets("GAUCHE Extrados (GE)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'colle les valeurs
    Sheets("Copie Données").Range("B5:S5").Copy
    Sheets("GAUCHE Intrados (GI)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
Else  'Si l'élément n'est pas un Gauche (ou si rien de marqué dans "E13")
    Sheets("Copie Données").Range("B12:T12").Copy
    Sheets("DROIT Extrados (DE)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'colle les valeurs
    Sheets("Copie Données").Range("B9:S9").Copy
    Sheets("DROIT Intrados (DI)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End If

Sheets("Tampon").Range("A1:G36").ClearContents
Sheets("A saisir").Range("E12:E14").ClearContents
Sheets("A saisir").Activate
Application.ScreenUpdating = True
End Sub
Le 16/07/2019 à 15:51

super merci beaucoup,

je test ça demain et je fais un retour

Le 17/07/2019 à 08:03
ThauThème a écrit :

Re,

La règle d'or en VBA c'est d'éviter autant que tu le peux les Select et autres Activate inutiles. Il ne font que ralentir l'exécution du code et sont source de plantage. Les conventions disent aussi de déclarer les variables en début de code. Cela permet à un autre utilisateur de repérer facilement les variables utilisées et de mieux lire ton code.

Le code Modifié :

Sub transfertdonnées()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination (carte de controle))
Dim CS As Workbook 'déclare la variable CS (Classeur Source (rapport de mesures))
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (Cellule de DESTination)
Dim R As Range 'déclare la variable R (Recherche)

Application.ScreenUpdating = False
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Tampon") 'définit l'onglet destination OD (à adapter à ton cas)
NumOF = Worksheets("A saisir").Range("E9").Value 'Vient récupérer le numéro d'OF
Set CS = Workbooks.Open("V:\Mes documents\A320 NEO\Rapport RPF\Rapport RPF Excel\" & NumOF & ".xls")
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS (à adapter à ton cas)
Set DEST = OD.Range("A1") 'définit la cellule de destination DEST (à adapter à ton cas)
Set R = OS.Columns(1).Find("Tableau d'entité géométrique", , xlValues, xlWhole) 'définit la recherche  R
's'il existe au moins une occurrence trouvée, copie la cellule R redimensionnée et la colle dans DEST
If Not R Is Nothing Then R.Resize(36, 6).Copy DEST
CS.Close False
'ferme le rapport de mesures après la copie et collage des valeurs

DG = Worksheets("A saisir").Range("E13").Value
If DG = "G" Then 'Si l'élément est un Gauche alors
    Sheets("Copie Données").Range("B2:T2").Copy
    Sheets("GAUCHE Extrados (GE)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'colle les valeurs
    Sheets("Copie Données").Range("B5:S5").Copy
    Sheets("GAUCHE Intrados (GI)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
Else  'Si l'élément n'est pas un Gauche (ou si rien de marqué dans "E13")
    Sheets("Copie Données").Range("B12:T12").Copy
    Sheets("DROIT Extrados (DE)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False 'colle les valeurs
    Sheets("Copie Données").Range("B9:S9").Copy
    Sheets("DROIT Intrados (DI)").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End If

Sheets("Tampon").Range("A1:G36").ClearContents
Sheets("A saisir").Range("E12:E14").ClearContents
Sheets("A saisir").Activate
Application.ScreenUpdating = True
End Sub

Salut !

Je viens de changer avec ton code et c'estsuper ça marche beaucoup mieux, c'est beaucoup plus fluide.

Merci beaucoup ton aide ça m'a vraiment aidé

Merci également à tous les autres pour leur aide

Problème résolu !

Rechercher des sujets similaires à "selectionner plage valeur partir texte precis"