Récupérer des données d'un excel à un autre

Poste au moins deux classeurs exemple. Je ne peux pas reconstituer à chaque fois de quoi tester.

Daniel

Bonjour Daniel,
Voici les fichiers
https://mon-partage.fr/f/pFqfBocT/
https://mon-partage.fr/f/5Laei2Hl/

Voici le programme :
Option Explicit
Public aa
Sub importer()
Dim fd As Object, fichier$, wbks As Workbook, m&, x$, y&, f As Range, fin&
Dim adr, a, mem$, rep, nom$
Application.ScreenUpdating = 1
Set fd = Application.FileDialog(1)
With fd
fichier = ThisWorkbook.Path: m = Len(fichier)
.Title = "Choisissez le Fichier du quel vous Souhaitez Importer les Données"
.InitialFileName = fichier & "\Fichier à Importer\"
.ButtonName = "Importer"
.Filters.Clear
.Filters.Add "Fichier Excel", "*.xlsm"
.AllowMultiSelect = False
If .Show <> 0 Then
nom = .SelectedItems(1)
a = Split(nom, "\"): mem = a(UBound(a))
mem = Mid(mem, 1, Len(mem) - 4)
Set wbks = Workbooks.Open(nom, 0)
aa = wbks.ActiveSheet.Range("A1:AP" & wbks.ActiveSheet.Range("A" & Rows.Count).End(3).Row)
wbks.Close 0
Call traiter
Else
MsgBox "Vous n'avez aucun Fichier Planning Equipe PMC, ou vous n'avez Séléctionné aucun fichier!!!", , "Manque de Fichier": Exit Sub
End If
End With
End Sub

Sub traiter()
Dim bb, a&, i&, n&, cc, fin&, d&, col&
With Feuil1
bb = .Range("A2:AP" & .Range("A" & Rows.Count).End(3).Row)
End With
ReDim cc(1 To UBound(aa), 1 To UBound(aa, 2))
For i = 1 To UBound(aa)
For a = 1 To UBound(bb)
If aa(i, 1) = bb(a, 1) Then
For col = 3 To UBound(bb, 2)
If aa(i, col) <> bb(a, col) Then bb(a, col) = aa(i, col)
Next col
GoTo 1
End If
Next a
n = n + 1
For d = 1 To UBound(bb, 2)
cc(n, d) = aa(i, d)
Next d
cc(n, 2) = cc(n, 3) & "-" & cc(n, 4) & "-" & cc(n, 5) & "-" & cc(n, 8) & "-" & cc(n, 9) & "-" & cc(n, 11)
1 Next i
With Feuil1
.Cells(3, 1).Resize(UBound(bb), UBound(bb, 2)).FormulaLocal = bb
fin = .Range("A" & Rows.Count).End(3).Row + 1
.Cells(fin, 1) = 1
.Cells(fin, 1).Resize(UBound(cc), UBound(cc, 2)).FormulaLocal = cc (ligne en erreur)
Call test
End With
End Sub
Sub test()
Dim fin&, i&
Application.ScreenUpdating = 0
With Feuil1
fin = .Range("A" & Rows.Count).End(3).Row
For i = fin To 3 Step -1
If .Cells(i, 1) = "" Then .Rows(i).Delete
Next i
End With
End Sub



Merci d'avance.

BAKI

Bonjour,

La macro s'exécute correctement, sans plantage, ici.

Daniel

Rebonjour,

Comme je l'indique sur le message avec le programme j'ai une erreur à la ligne en gras et je comprend pas pourquoi.
Sur mon projet réel j'ai beaucoup plus de données que ça mais je ne comprend pas l'erreur.
Vous ne voyez vraiment pas ce qui pourrai clocher ?

Merci d'avance.

BAKI