Copie de lignes de plusieurs feuilles selon un critère en colonne variable et transfert dans un autre classeur

**thomy276** · 16/01/2019, 18h01

Bonjour,

Je cherche à copier des lignes de plusieurs feuilles d'un classeur en sélectionnant la colonne par recherche du nom de l'en-tête puis recherche du critère dans la colonne et coller le tout dans une feuille d'un autre classeur.
Je n'arrive pas à intégrer la variable de recherche de colonne...
J'ai essayé avec ce code et d'autres sans résultat...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Macro1()
Dim WS As Worksheet 'déclare la variable WS (WorkSheet)
Dim R As Worksheet 'déclare la variable R (Recapmois)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim COL As Integer
 
Set R = Worksheets("Feuil1") 'définit l'onglet R
 
With Workbooks("Data.xlsm")
For Each WS In Worksheets 'boucle 1 : sur tous les onglets
    Select Case WS.Name 'agit en fonction du nom de l'onglet
        Case "Feuil2", "Feuil3", "Extraction", "Calcul", "Tri", "Format Initial" '(rien ne se passe)
        Case Else 'autres cas
            DL = WS.Cells(Application.Rows.Count, "B").End(xlUp).Row 'définir la dernière ligne éditée DL de l'onglet de la boucle
            For I = 13 To DL 'boucle 2 : sur toutes les lignes I de l'onglet de la boucle (de 13 a DL)
                COL = WS.Rows(1).Find("Coach H", , xlValues, xlWhole).Column
 
                If WS.Cells(I, "K") <> "" Then 'condition : si la cellule ligne I, colonne K n'est pas vide
                    Set DEST = R.Cells(Application.Rows.Count, 2).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
                    WS.Cells(I, "B").Resize(1, 14).Copy DEST 'copie la ligne I (la cellule ligne I colonne B redimensionné à 14 colonnes) et la colle dans DEST
                End If 'fin de la condition
            Next I 'prochaine ligne de la boucle 2
    End Select 'fin de l'action en fontion du nom de l'onglet
Next WS 'prochain onglet de la boucle 1
End With
End Sub

Merci d'avance pour votre aide

**ARTURO83** · 16/01/2019, 18h29

Bonsoir,

A tester
"Case is = "

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

      Case is = "Feuil2", "Feuil3", "Extraction", "Calcul", "Tri", "Format Initial"

Cdlt

**thomy276** · 16/01/2019, 18h59

Bonsoir ARTURO83

Merci pour la réponse mais je n'ai pas compris, j'aimerais recherche la colonne de critère
Est-ce possible de définir "k" If WS.Cells(I, "K") <> "" Then à partir d'une recherche type COL = WS.Rows(1).Find("Coach H", , xlValues, xlWhole).Column.

**Thautheme** · 16/01/2019, 19h11

Bonsoir le fil, bonsoir le forum,

Tiens je connais ce code...
Essaie comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OS As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CD (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim RC As Range 'déclare la variable RC (Recherche Colonne)
Dim COL As Integer 'déclare la variable COL (COLonne)
 
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Feuil1") 'définit l'onglet destination OD
Set CS = Workbooks("Data.xlsm")
For Each OS In CS.Worksheets 'boucle 1 : sur tous les onglets du classeur source
    Select Case OS.Name 'agit en fonction du nom de l'onglet
        Case "Feuil2", "Feuil3", "Extraction", "Calcul", "Tri", "Format Initial" '(rien ne se passe)
        Case Else 'autres cas
            Set RC = OS.Rows(1).Find("Coach H", , xlValues, xlWhole) 'définit la recherche de colonne RC
            If Not RC Is Nothing Then 'condition : s'il existe une occurrence trouvée
                COL = R.Column 'définit la colonne COL
            Else 'sinon
                goro suite 'va à l'étiquette "suite"
            End If 'fin de la condition
            DL = OS.Cells(Application.Rows.Count, "B").End(xlUp).Row 'définir la dernière ligne éditée DL de l'onglet de la boucle
            For I = 13 To DL 'boucle 2 : sur toutes les lignes I de l'onglet de la boucle (de 13 a DL)
                 If OS.Cells(I, COL) <> "" Then 'condition : si la cellule ligne I, colonne COL n'est pas vide
                    Set DEST = OD.Cells(Application.Rows.Count, 2).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
                    OS.Cells(I, "B").Resize(1, 14).Copy DEST 'copie la ligne I (la cellule ligne I colonne B redimensionné à 14 colonnes) et la colle dans DEST
                End If 'fin de la condition
            Next I 'prochaine ligne de la boucle 2
    End Select 'fin de l'action en fontion du nom de l'onglet
suite: 'étiquette
Next OS 'prochain onglet de la boucle 1
End Sub

**thomy276** · 22/01/2019, 00h06

Bonsoir
Merci beaucoup !

j'avoue plancher sur quelqu'une de vos macros...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Private Sub CommandButton1_Click()
 
 
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CD (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim RC As Range 'déclare la variable RC (Recherche Colonne)
Dim COL As Integer 'déclare la variable COL (COLonne)
Dim ETT As String 'déclare la variable ETT (en-tete)
 
Set CD = Workbooks(ComboBox2.Text) 'définit le classeur destination CD
Set OD = CD.Worksheets(TextBox1.Text) 'définit l'onglet destination OD
Set CS = Workbooks(ComboBox1.Text) 'définit le classeur source CS
 
ETT = TextBox2.Text
 
 
For Each OS In CS.Worksheets 'boucle 1 : sur tous les onglets du classeur source
    Select Case OS.Name 'agit en fonction du nom de l'onglet
        Case "Feuil2", "Feuil3", "Extraction", "Calcul", "Tri", "Format Initial" '(rien ne se passe)
        Case Else 'autres cas
            Set RC = OS.Rows(3).Find(what:=ETT, LookIn:=xlValues, lookat:=xlWhole) 'définit la recherche de colonne RC
            If Not RC Is Nothing Then 'condition : s'il existe une occurrence trouvée
                COL = RC.Column 'définit la colonne COL
            Else 'sinon
                GoTo suite  'va à l'étiquette "suite"
            End If 'fin de la condition
            DL = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définir la dernière ligne éditée DL de l'onglet de la boucle
            For I = 1 To DL 'boucle 2 : sur toutes les lignes I de l'onglet de la boucle (de 13 a DL)
                 If OS.Cells(I, COL).Value >= "1" And OS.Cells(I, COL).Value <= "1,4" Then   'condition : si la cellule ligne I, colonne COL n'est pas vide
                    Set DEST = OD.Cells(Application.Rows.Count, 2).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
                    OS.Cells(I, "A").Resize(1, 200).Copy DEST 'copie la ligne I (la cellule ligne I colonne B redimensionné à 14 colonnes) et la colle dans DEST
                End If 'fin de la condition
            Next I 'prochaine ligne de la boucle 2
    End Select 'fin de l'action en fontion du nom de l'onglet
suite: 'étiquette
Next OS 'prochain onglet de la boucle 1
 
Unload UserForm1
End Sub

Juste une question, "if" peut faire référence à une cellule ? mais qu'en est-il du critère "=" ?
Si ce n'est pas le cas des pistes de réflexion svp
mERCI