Voila un code qui copie toute les données d'un fichier (touts les feuille) à toi de l'adapter.
Désol pour les fautes d'orthographe
'Fait par Waurzyczka Vincent
Sub Import()
Dim Tempon As Integer
Dim CptLigne As Long
Dim CptColone As Long
Dim CptFeuil As Integer: CptFeuil = 1
Dim PremLigne As Long
Dim PremColone As Long
Dim DerLigne As Long
Dim DerColone As Long
Dim CptLigneInsert As Long: CptLigneInsert = 1
'Ne fait rien si l'utilisateur répond "Non"
If MsgBox("Le programme vas vous proposer d'ouvrir un fichier." & Chr(10) & Chr(13) & "Merci de sélectionner le fichier d'où extraire les donnée." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Attention il faut que seul le fichier contenant le programme soit ouvert." & Chr(10) & Chr(13) & "Voulez vous continuer?", vbYesNo, "Attention") = vbYes Then
Application.Dialogs(xlDialogOpen).Show 'Ouvre la fenaitre d'ouverture de fichier
'-------------------------
'Gestion d'erreur : trop de fichier ouvert
If Application.Workbooks.Count <> 2 Then
Tempon = MsgBox("Erreur trop de fichier sont ouvert merci de fermer tout fichier Excel sauf celui contenant le programme.", vbOKOnly, "Erreur")
Exit Sub
End If
'--------------------------
Application.Workbooks(1).Activate 'Active le fichier programme
Worksheets.Add 'Ajoute un onglet où mettre les donnée en tempon
Worksheets(1).Select 'Selection le nouvelle onglet
Application.Workbooks(2).Activate 'Selection du fichier d'où on prend les donnée (nomé "EXTRACT" a partir de maintenant)
Worksheets(1).Select 'Selection du 1ér onglet de "EXTRACT"
Do While CptFeuil <= Worksheets.Count 'Faire temps que tout les onglet n'on pas été verif
PremLigne = 0 '\
PremColone = 0 ' |
DerLigne = 0 ' >Initialisation des marque
DerColone = 0 ' |
CptColone = 1 '/
Worksheets(CptFeuil).Select 'Selction de la feuille suivante
Do While CptColone < 257 'Pour les 256 colone (compteur STRICTEMENT inférieur à)
CptLigne = 1 'Initialisation du compteur ligne
Do While CptLigne < 65536 'Pour toute les ligne
Cells(CptLigne, CptColone).Select 'Selectione la cellule en cours
If ActiveCell = "" Then 'Si la cellule est vide
Selection.End(xlDown).Select 'Passe directement à la valeur suivante (equivalent à la comande "Ctrl" + Fléche directionelle )
'Le compteur ligne est egale au num ligne de la cellule celectionnée
CptLigne = Val(Split(Selection.Address(True, True, xlR1C1), "R")(1))
End If
If ActiveCell <> "" Then 'Si la cellule est non vide
If PremLigne = 0 Or PremLigne > CptLigne Then 'Si la 1ér ligne non détect ou supérieur à ligne en cours
PremLigne = CptLigne 'Sauv du num ligne
End If
If DerLigne < CptLigne Then 'Si num derligne est inférieur a la ligne en cours
DerLigne = CptLigne 'Sauv du num ligne
End If
If PremColone = 0 Then 'Si 1ér colone non détect
PremColone = CptColone 'Sauv du num colone
End If
If DerColone < CptColone Then 'Si num dérinere colone inférieur à la colone en cours
DerColone = CptColone 'Sauv du num colone
End If
CptLigne = CptLigne + 1 'Passe à la ligne suivante
End If
Loop
CptColone = CptColone + 1 'Passe à la colone suivante
Loop
If PremLigne <> 0 Then 'Si des donnée on été détect (soit les marqueur défini)
Range(Cells(PremLigne, PremColone), Cells(DerLigne, DerColone)).Select 'Selectione tout ce qui est dans les marqueurs
Else
Range(Cells(1, 1), Cells(1, 1)).Select 'Selectione la 1ér cellule
End If
'-----------
'Défusione les cellule de la selection
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'-------------
Selection.Copy 'Met dans le presse papier la selection
Application.Workbooks(1).Activate 'Retourne dans le fichier programme
Cells(CptLigneInsert, 1).Select 'Vas à la ligne compteur d'insersion
'Colle le format des donnée en presse papier (gras, couleur de cellule, ..., pas les bodure)
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Colle les donnée
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'----------------------
'Cadre autous donnée
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'----------------------
'Avance le compteur d'insersion du nombre de ligne insérer + 1 (ligne suivante de l'insertion)+ 4 ligne vide
CptLigneInsert = CptLigneInsert + DerLigne - PremLigne + 5
'Passe le marqueur d'onglet au suivant (marqueur de "EXTRACT")
CptFeuil = CptFeuil + 1
'Retourne dans le fichier "EXTRACT"
Application.Workbooks(2).Activate
Loop
End If
'Toute les donnée on été ramener dans l'onglet tempon de Programme
'Ferme le fichier "EXTRACT" sans sauvgarder le modification
Application.Workbooks(2).Close (False)
Workbooks.Add 'Crée un nouveau fichier
Application.Workbooks(2).Activate 'Active le nouveau fichier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
ActiveSheet.Paste 'Colle le contenu du presse papier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
Application.Workbooks(1).Activate 'Retourne sur le fichier programme
Application.DisplayAlerts = False 'Désactive les alerte excel (si non demande confirmation pour suprimer le tempon)
Worksheets(1).Delete 'Suprime l'onglet tempon
Application.DisplayAlerts = True 'Réactive les alerte excel
End Sub
En résumer ce code improte toute les données d'un fichier dans un nouvel onglet du fichier dans le quel se trouve le code puis crée un nouveau fichier où coller les données. Tu dois pouvoir l'adapter facilement (plien de commentaire partout)
Voila
Faut pas s'enerver