Copy paste données

Version imprimable

Copy paste données

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:

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

Bonjour,

Code:

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

26/11/2018, 16h12
rossemma

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

correct ??

Code:

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

26/11/2018, 16h24
rossemma

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

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

Peut être que la modification suivante va marcher :

Code:

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

26/11/2018, 23h07
rossemma

cela ne fonctionne pas
Il ne copie pas la valeur de la cellule C9 dans la dernière colonne et sur toutes les lignes copiées.

Hmmm... Peut-être que le code suivant fonctionnerait mieux :

Code:

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
Public 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 = 16 '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 = "TEST\"
 
'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
                Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy
                Set SourceValue = Feuil2.Range("C9") 'MODIFIER L'ADRESSE DE LA PLAGE SOURCE ICI
                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(sh_globalkrc.Cells(CopyTarget.Row, FillColumn), sh_globalkrc.Cells(sh_globalkrc.Range("A1048576").End(xlUp).Row, FillColumn))
                FillTarget = SourceValue.Value
                'vide le presse papier
                Call ClearClipboard
            End If
            'ferme le fichier trouvé en cours
            wb.Close False
            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

Un peu dur à tester sans les fichiers cela dit donc ce n'est pas garanti que ça fonctionne.

27/11/2018, 10h51
rossemma

non cela ne fonctionne pas :calim2:
27/11/2018, 11h33
Mr Poulpe

Un peu de précision serait bienvenu... Encore une fois, c'est assez difficile de tester ce code.

Par ailleurs, la feuille "feuil2" se situe dans quel classeur?
27/11/2018, 11h38
rossemma

en fait g un classeur avec un feuil2 de laquelle je copie des lignes.
Dans la même feuille en cellule C9, g une donnée que je voudrais aussi copier mais je voudrais que celle ci se colle en fin de chaque ligne copié

Donc, je copie donnée de A5 à O25 de la feuill2 vers sh_globalkrc.
en colonne P je voudrais collée la valeur de C9 et ce dans chaque ligne

Hum... Encore un essai :

Code:

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
Public 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 = 16 '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 wb.Sheets("Feuil2").Range("k3") = "oui / ja" Then
                wb.Sheets("Feuil2").Range("B13:N" & wb.Sheets("Feuil2").UsedRange.Rows.Count).Copy
                Set SourceValue = wb.Sheets("Feuil2").Range("C9") 'MODIFIER L'ADRESSE DE LA PLAGE SOURCE ICI
                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(sh_globalkrc.Cells(CopyTarget.Row, FillColumn), sh_globalkrc.Cells(sh_globalkrc.Range("A1048576").End(xlUp).Row, FillColumn))
                FillTarget = SourceValue.Value
                'vide le presse papier
                'Call ClearClipboard
            End If
            'ferme le fichier trouvé en cours
            wb.Close False
            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

Attention à ce que l'onglet s'appelle bien "feuil2"...

27/11/2018, 12h04
rossemma

Citation:

Attention à ce que l'onglet s'appelle bien "feuil2"...

que veux tu dire ?

nom dans code.name VBA ou le vrai nom de l'onglet??
27/11/2018, 13h37
Mr Poulpe

Le nom de l'onglet en l'occurence, par rapport à ce que j'ai présenté précédemment (pas le codename vba).
27/11/2018, 14h50
rossemma

Merci pour l'aide mais toujours rien
27/11/2018, 16h08
Mr Poulpe

Ce serait possible de me mettre un exemplaire du fichier à consolider et celui intégrant la macro? Quitte à anonymiser les données si confidentiel.

Très compliqué de tester sinon...

J'essaierai de regarder ça ce soir.
27/11/2018, 20h24
rossemma

2 pièce(s) jointe(s)

Voilà les fichiers :
Pièce jointe 430417 Pièce jointe 430418

Bon. J'ai réussi à faire fonctionner une "solution" qui, j'espère, résoudra le problème :

Code:

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
74
75
76
77
Private Sub CommandButton2_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 CopyRangeRowCount As Integer
Dim SourceValue As Range
 
Const FillColumn = 14 '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.Range("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 wb.Sheets("KRC").Range("k3") = "Oui / Ja" Then
                CopyRangeRowCount = wb.Sheets("KRC").UsedRange.Rows.Count
                wb.Sheets("KRC").Range("B13:N" & CopyRangeRowCount).Copy
 
                Set SourceValue = wb.Sheets("KRC").Range("C9") 'MODIFIER L'ADRESSE DE LA PLAGE SOURCE ICI
                Set CopyTarget = sh_GlobalKrc.Range("A1048576").End(xlUp).Offset(1, 0)
                CopyTarget.PasteSpecial Paste:=xlPasteValues, operation _
                    :=xlNone, skipblanks:=False, Transpose:=False
 
                Set FillTarget = ThisWorkbook.Sheets("Feuil1").Range(Cells(CopyTarget.Row, FillColumn).Address & ":" & Cells(CopyTarget.Row + CopyRangeRowCount, FillColumn).Address)
                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

Quelques commentaires toutefois :

Sur la ligne :

Code:

Range("B13:N" & ActiveSheet.UsedRange.Rows.Count).Copy

Ici, tu copie bien plus de lignes que nécessaire depuis ton classeur source. En effet, la plage active (usedrange) comprend de nombreuses lignes vides, si jamais celles-ci ont été remplies à un moment. Conséquence : beaucoup de lignes vides sont copiées dans le tableau.

Il serait bien plus prudent et plus simple de recourir à un tableau Excel :

https://excel.developpez.com/faq/?page=Tableau

Comme ça, tu aurais juste à copier le tableau, sans avoir à savoir jusqu'à quelle ligne il va puisqu'il s'incrémente automatiquement (attention toutefois à ce que les utilisateurs n'inscrivent pas des éléments au delà du tableau.

Au niveau de :

Code:

On Error Resume Next

Pourquoi vouloir ignorer les erreurs qui peuvent se produire? Cela complexifie considérablement le débugage (si jamais tu ne l'enlève pas avant de débuguer), et c'est assez rare qu'on veuille simplement ignorer les erreurs.

Je te réfère à la documentation suivante concernant la gestion des erreurs en VBA :

https://silkyroad.developpez.com/VBA/GestionErreurs/

Cela dit, j'espère que ça marchera pour de bon cette fois.

Bien cordialement,

Poulpe

28/11/2018, 11h29
rossemma

Merci pour ton aide, je vais regarder.

Pour le On Error Resume Next, oublié de le supprimer.
Je n'avais pas remarquer mon oubli, merci.