BienvenueBonjour Forum,
j'ai besoin d'un code qui me permet des copier des colonnes non consécutives d'une feuille fermé (test ) adresse (C:\) et coller dans ma feuille actuelle (base) dans des colonnes non consécutives aussi
merci d'avance
Bonjour cp4,le forum
Sub Extraction()
'copie de test vers base -'colA vers colA - 'colD vers colD - 'colT vers colG - 'colU vers colJ
Dim filePath As String, TestWb As Workbook, BaseWb As Workbook, dl As Long
Set BaseWb = ActiveWorkbook
With BaseWb.Sheets("feuil1") 'on vide' les colonnes concernées
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
Application.Union(.Range("A2:A" & dl), .Range("D2:D" & dl), .Range("G2:G" & dl), .Range("J2:J" & dl)).Cells.ClearContents
End With
filePath = ThisWorkbook.Path & Application.PathSeparator & "test.xlsx" 'chemin à adapter
Set TestWb = Workbooks.Open(filePath) 'on ouvre le fichier'
With TestWb.Sheets("feuil1")
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
.Range("A2:A" & dl).Copy BaseWb.Sheets("feuil1").Range("A2")
.Range("D2:D" & dl).Copy BaseWb.Sheets("feuil1").Range("D2")
.Range("T2:T" & dl).Copy BaseWb.Sheets("feuil1").Range("G2")
.Range("U2:U" & dl).Copy BaseWb.Sheets("feuil1").Range("J2")
End With
TestWb.Close 'on ferme le fichier'
MsgBox "Extraction terminée!"
End Sub
Bonjour Cp4,merci pour ce code!Bonjour,
Il est plus simple qu'on ouvre et ferme par code le fichier.
Voici un essaie, mais n'oublie pas d'enregistrer le fichier base au format xlsm, ensuite colle le code ci-dessous dans un module standard et adapte le chemin de ton fichier 'test.xslx'.
A+VB:Sub Extraction() 'copie de test vers base -'colA vers colA - 'colD vers colD - 'colT vers colG - 'colU vers colJ Dim filePath As String, TestWb As Workbook, BaseWb As Workbook, dl As Long Set BaseWb = ActiveWorkbook With BaseWb.Sheets("feuil1") 'on vide' les colonnes concernées dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row Application.Union(.Range("A2:A" & dl), .Range("D2:D" & dl), .Range("G2:G" & dl), .Range("J2:J" & dl)).Cells.ClearContents End With filePath = ThisWorkbook.Path & Application.PathSeparator & "test.xlsx" 'chemin à adapter Set TestWb = Workbooks.Open(filePath) 'on ouvre le fichier' With TestWb.Sheets("feuil1") dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row .Range("A2:A" & dl).Copy BaseWb.Sheets("feuil1").Range("A2") .Range("D2:D" & dl).Copy BaseWb.Sheets("feuil1").Range("D2") .Range("T2:T" & dl).Copy BaseWb.Sheets("feuil1").Range("G2") .Range("U2:U" & dl).Copy BaseWb.Sheets("feuil1").Range("J2") End With TestWb.Close 'on ferme le fichier' MsgBox "Extraction terminée!" End Sub
le nom de fichier test et le nom de feuille chaque mois sont modifiées y'a-til d'astuce pour n'as pas changé le code a chaque fois ?Bonjour Cp4,merci pour ce code!
mais possible de modifier le code pour faire collage spéciale ?
Bonjour Sandra,Bonjour Cp4,merci pour ce code!
mais possible de modifier le code pour faire collage spéciale ?
Bonjour,le nom de fichier test et le nom de feuille chaque mois sont modifiées y'a-til d'astuce pour n'as pas changé le code a chaque fois ?
Bonjour,Bonjour,
Est-ce que le fichier a plusieurs feuilles ou une seule comme ton fichier joint test.xlsx?
A+
Ok, pour une seule feuille ci-dessous code à tester. Pour le collage special, j'ai corrigé le code (collage valeur).Bonjour,
oui plusieurs feuilles
Sub ExtractionChoixFichier()
'copie de test vers base -'colA vers colA - 'colD vers colD - 'colT vers colG - 'colU vers colJ
Dim filePath As String, TestWb As Workbook, BaseWb As Workbook, dl As Long
Set BaseWb = ActiveWorkbook
With BaseWb.Sheets("feuil1")
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
Application.Union(.Range("A2:A" & dl), .Range("D2:D" & dl), .Range("G2:G" & dl), .Range("J2:J" & dl)).Cells.ClearContents
End With
'ouvrir fenetre choix fichier
Dim Nom_Fichier As Variant
Nom_Fichier = Application.GetOpenFilename("Fichiers Excel (*.xlsx), *.xlsx")
If Nom_Fichier <> False Then
Set TestWb = Workbooks.Open(Nom_Fichier)
TestWb.Activate
End If
With ActiveSheet
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
.Range("A2:A" & dl).Copy
BaseWb.Sheets("feuil1").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("D2:D" & dl).Copy
BaseWb.Sheets("feuil1").Range("D2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("T2:T" & dl).Copy
BaseWb.Sheets("feuil1").Range("G2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("U2:U" & dl).Copy
BaseWb.Sheets("feuil1").Range("J2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
TestWb.Close
MsgBox "Extraction terminée!"
End Sub
Sub ExtractionChoixFichier()
'copie de test vers base -'colA vers colA - 'colD vers colD - 'colT vers colG - 'colU vers colJ
Dim filePath As String, TestWb As Workbook, BaseWb As Workbook, dl As Long
Application.ScreenUpdating = False
Set BaseWb = ActiveWorkbook
With BaseWb.Sheets("feuil1")
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
Application.Union(.Range("A2:A" & dl), .Range("D2:D" & dl), .Range("G2:G" & dl), .Range("J2:J" & dl)).Cells.ClearContents
End With
'ouvrir fenetre choix fichier
Dim Nom_Fichier As Variant
Nom_Fichier = Application.GetOpenFilename("Fichiers Excel (*.xlsx), *.xlsx")
If Nom_Fichier <> False Then
Set TestWb = Workbooks.Open(Nom_Fichier)
TestWb.Activate
End If
'''choix onglet
Dim Source As String
Source = InputBox("Saisir nom de l'onglet à copier")
If Source = "" Then GoTo fin 'si aucune saisie nom onglet
If Existe(Source) Then 'verification onglet existe
With Sheets(Source)
dl = .UsedRange.Rows(.UsedRange.Rows.Count).Row
.Range("A2:A" & dl).Copy
BaseWb.Sheets("feuil1").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("D2:D" & dl).Copy
BaseWb.Sheets("feuil1").Range("D2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("T2:T" & dl).Copy
BaseWb.Sheets("feuil1").Range("G2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("U2:U" & dl).Copy
BaseWb.Sheets("feuil1").Range("J2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
MsgBox "Extraction terminée!"
Else
MsgBox "L'onglet " & Source & " n'existe pas dans le fichier " & Dir(Nom_Fichier)
End If
fin:
TestWb.Close
Application.ScreenUpdating = True
End Sub
Function Existe(nom) As Boolean 'mapomme
On Error Resume Next: Existe = IsObject(Sheets(nom)): Err.Clear
End Function