XL 2013 VBA copier coller deux feuilles

sendra

XLDnaute Nouveau
Bonjour 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
 

cp4

XLDnaute Barbatruc
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'.
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
A+
 

sendra

XLDnaute Nouveau
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'.
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
A+
Bonjour Cp4,merci pour ce code!
mais possible de modifier le code pour faire collage spéciale ?
 

cp4

XLDnaute Barbatruc
Bonjour,
oui plusieurs feuilles
Ok, pour une seule feuille ci-dessous code à tester. Pour le collage special, j'ai corrigé le code (collage valeur).
Pour plusieurs feuilles, je verrai ça plus tard car j'aide un autre membre.
VB:
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
 

cp4

XLDnaute Barbatruc
Pour fichier ayant plusieurs feuilles.
VB:
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
 

Discussions similaires