Copy paste données

**rossemma** · 26/11/2018, 16h04

Bonjour et d'avance merci pour votre aide,

Dans le code ci-dessous, je fais un copy/paste à partir de plusieurs fichiers.
Je voudrais ajouter un condition avant de copy/paste à savoir si dans la cellule K3 de chaque fichier il y a un X alors je copie les données sinon je passe au fichier suivant.
De plus, le code copie plusieurs lignes mais dans le fichier ouvert il y a une cellule (unique) avec un nom que je voudrais coller à côté de chaque ligne copiée.

J'espère m'être correctement exprimé.

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Private Sub CommandButton1_Click()
 
On Error Resume Next
 
Dim chemin As String, KRCFile As String
Dim folder As Variant, box As Variant
Dim NBFichier As Integer
Dim wb As Workbook
 
'définit le répertoire contenant les fichiers
chemin = ThisWorkbook.Path & Application.PathSeparator
folder = "KRC_GB-BH\"
 
'tous les fichiers krc*.xlsx du folder
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If KRCFile <> "" Then
'boucle => nombre de fichiers trouvés dans le folder
    While Not KRCFile = ""
        NBFichier = NBFichier + 1
        KRCFile = Dir
    Wend
Else: MsgBox "Not Files in the folder"
Exit Sub
End If
 
box = MsgBox("Find" & " " & NBFichier & " " & "file(s)" & " " & "?", vbYesNo + vbQuestion + vbApplicationModal + vbDefaultButton2, "")
 
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If box = vbYes Then
    If KRCFile <> "" Then
        Application.StatusBar = "Old data erased"
        sh_GlobalKrc("A5:O" & ActiveSheet.UsedRange.Rows.Count - 1).ClearContents
        Application.StatusBar = "Import in progess....."
        Application.ScreenUpdating = False
        Do While KRCFile <> ""
            Application.EnableEvents = False
            'ouvre le fichier trouvé
            Set wb = Workbooks.Open(chemin & folder & KRCFile, local:=True, ReadOnly:=True)
            Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy
            sh_GlobalKrc.Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, operation _
                :=xlNone, skipblanks:=False, Transpose:=False
            'vide le presse papier
            Call ClearClipboard
            'ferme le fichier trouvé en cours
            wb.Close True
            Set wb = Nothing
            KRCFile = Dir
        Loop
        MsgBox "Import OK"
        Columns("A:O").AutoFit
        Application.Goto reference:=Range("A5")
        Application.ScreenUpdating = True
        Application.StatusBar = False
        Application.EnableEvents = True
    End If
End If
 
End Sub

**Mr Poulpe** · 26/11/2018, 16h08

Bonjour,

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Private Sub CommandButton1_Click()
 
On Error Resume Next
 
Dim chemin As String, KRCFile As String
Dim folder As Variant, box As Variant
Dim NBFichier As Integer
Dim wb As Workbook
 
'définit le répertoire contenant les fichiers
chemin = ThisWorkbook.Path & Application.PathSeparator
folder = "KRC_GB-BH\"
 
'tous les fichiers krc*.xlsx du folder
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If KRCFile <> "" Then
'boucle => nombre de fichiers trouvés dans le folder
    While Not KRCFile = ""
        NBFichier = NBFichier + 1
        KRCFile = Dir
    Wend
Else: MsgBox "Not Files in the folder"
Exit Sub
End If
 
box = MsgBox("Find" & " " & NBFichier & " " & "file(s)" & " " & "?", vbYesNo + vbQuestion + vbApplicationModal + vbDefaultButton2, "")
 
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If box = vbYes Then
    If KRCFile <> "" Then
        Application.StatusBar = "Old data erased"
        sh_GlobalKrc("A5:O" & ActiveSheet.UsedRange.Rows.Count - 1).ClearContents
        Application.StatusBar = "Import in progess....."
        Application.ScreenUpdating = False
        Do While KRCFile <> ""
            Application.EnableEvents = False
            'ouvre le fichier trouvé
            Set wb = Workbooks.Open(chemin & folder & KRCFile, local:=True, ReadOnly:=True)
     	    if range("K3")= "X" then 
            	Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy
            	sh_GlobalKrc.Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, operation _
	                :=xlNone, skipblanks:=False, Transpose:=False
         	   'vide le presse papier
            	Call ClearClipboard
            End if
            'ferme le fichier trouvé en cours
            wb.Close True
            Set wb = Nothing
            KRCFile = Dir
        Loop
        MsgBox "Import OK"
        Columns("A:O").AutoFit
        Application.Goto reference:=Range("A5")
        Application.ScreenUpdating = True
        Application.StatusBar = False
        Application.EnableEvents = True
    End If
End If
 
End Sub

A noter que ce code dépend de la feuille qui est active lors de l'ouverture du fichier. Ce serait plus propre de se référer explicitement à une feuille spécifique du classeur pour réaliser ces opérations.

Bien cordialement,

Poulpe

**rossemma** · 26/11/2018, 16h12

merci pour la remarque, je vais adapter et reposter pour check

pour la cellule K3, je mettais le end if trop bas dans le code

**rossemma** · 26/11/2018, 16h16

correct ??

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Private Sub CommandButton1_Click()
 
On Error Resume Next
 
Dim chemin As String, KRCFile As String
Dim folder As Variant, box As Variant
Dim NBFichier As Integer
Dim wb As Workbook
 
'définit le répertoire contenant les fichiers
chemin = ThisWorkbook.Path & Application.PathSeparator
folder = "KRC_GB-BH\"
 
'tous les fichiers krc*.xlsx du folder
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If KRCFile <> "" Then
'boucle => nombre de fichiers trouvés dans le folder
    While Not KRCFile = ""
        NBFichier = NBFichier + 1
        KRCFile = Dir
    Wend
Else: MsgBox "Not Files in the folder"
Exit Sub
End If
 
box = MsgBox("Find" & " " & NBFichier & " " & "file(s)" & " " & "?", vbYesNo + vbQuestion + vbApplicationModal + vbDefaultButton2, "")
 
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If box = vbYes Then
    If KRCFile <> "" Then
        Application.StatusBar = "Old data erased"
        sh_GlobalKrc("A5:O" & ActiveSheet.UsedRange.Rows.Count - 1).ClearContents
        Application.StatusBar = "Import in progess....."
        Application.ScreenUpdating = False
        Do While KRCFile <> ""
            Application.EnableEvents = False
            'ouvre le fichier trouvé
            Set wb = Workbooks.Open(chemin & folder & KRCFile, local:=True, ReadOnly:=True)
            If Feuil2.Range("k3") = "oui / ja" Then
                Feuil2.Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy
                sh_GlobalKrc.Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, operation _
                    :=xlNone, skipblanks:=False, Transpose:=False
                'vide le presse papier
                Call ClearClipboard
            End If
            'ferme le fichier trouvé en cours
            wb.Close True
            Set wb = Nothing
            KRCFile = Dir
        Loop
        MsgBox "Import OK"
        Columns("A:O").AutoFit
        Application.Goto reference:=Range("A5")
        Application.ScreenUpdating = True
        Application.StatusBar = False
        Application.EnableEvents = True
    End If
End If
 
End Sub

**rossemma** · 26/11/2018, 16h24

une idée pour la deuxième partie de mon problème ??

**Mr Poulpe** · 26/11/2018, 20h38

Oups je n'avais pas vu la deuxième partie.

Peut être que la modification suivante va marcher :

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Private Sub CommandButton1_Click()
 
On Error Resume Next
 
Dim chemin As String, KRCFile As String
Dim folder As Variant, box As Variant
Dim NBFichier As Integer
Dim wb As Workbook
Dim CopyTarget As Range
Dim FillTarget As Range
Dim SourceValue As Range
 
Const FillColumn = 10 'REMPLACER LE NUMERO DE LA COLONNE DANS LAQUELLE EST COPIEE LA VALEUR FIXE ICI
 
 
 
'définit le répertoire contenant les fichiers
chemin = ThisWorkbook.Path & Application.PathSeparator
folder = "KRC_GB-BH\"
 
'tous les fichiers krc*.xlsx du folder
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If KRCFile <> "" Then
'boucle => nombre de fichiers trouvés dans le folder
    While Not KRCFile = ""
        NBFichier = NBFichier + 1
        KRCFile = Dir
    Wend
Else: MsgBox "Not Files in the folder"
Exit Sub
End If
 
box = MsgBox("Find" & " " & NBFichier & " " & "file(s)" & " " & "?", vbYesNo + vbQuestion + vbApplicationModal + vbDefaultButton2, "")
 
KRCFile = Dir(chemin & folder & "KRC" & "*.xlsx")
 
If box = vbYes Then
    If KRCFile <> "" Then
        Application.StatusBar = "Old data erased"
        sh_globalkrc("A5:O" & ActiveSheet.UsedRange.Rows.Count - 1).ClearContents
        Application.StatusBar = "Import in progess....."
        Application.ScreenUpdating = False
        Do While KRCFile <> ""
            Application.EnableEvents = False
            'ouvre le fichier trouvé
            Set wb = Workbooks.Open(chemin & folder & KRCFile, local:=True, ReadOnly:=True)
            If feuil2.Range("k3") = "oui / ja" Then
                feuil2.Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy
                Set CopyTarget = sh_globalkrc.Range("A1048576").End(xlUp).Offset(1, 0)
                CopyTarget.PasteSpecial Paste:=xlPasteValues, operation _
                    :=xlNone, skipblanks:=False, Transpose:=False
                Set FillTarget = sh_globalkrc.Range(Cells(CopyTarget.Row, FillColumn), Cells(sh_globalkrc.Range("A1048576").End(xlUp).Row, FillColumn))
                Set SourceValue = feuil2.Range("A1") 'MODIFIER L'ADRESSE DE LA PLAGE SOURCE ICI
                FillTarget = SourceValue.Value
                'vide le presse papier
                Call ClearClipboard
            End If
            'ferme le fichier trouvé en cours
            wb.Close True
            Set wb = Nothing
            KRCFile = Dir
        Loop
        MsgBox "Import OK"
        Columns("A:O").AutoFit
        Application.Goto reference:=Range("A5")
        Application.ScreenUpdating = True
        Application.StatusBar = False
        Application.EnableEvents = True
    End If
End If
 
End Sub

Ne pas oublier d'indiquer le numéro de la colonne dans laquelle sont copiées les valeurs, et l'adresse de la valeur source.

Désolé si la solution n'est pas très élégante mais je manque d'inspiration...

Bien cordialement,

Poulpe

Copy paste données

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager