XL 2013 Copier coller d'une feuille vers une autre feuille

[SAMESS]

Bonjour Forum,
j'ai besoin d'un macro qui fait copier la colonne A,B et C a partir de l'adresse A2,B2 et C2 vers la dernière ligne qui non vide) feuille FF(lien de feuille C:\FicheExel)vers la feuille actuelle et écrire dans la colonne D le non de fichier
merci d'avance

 

[fanch55]

Bonjour,
Code à mettre dans un module de FF.xlsx
Vérifiez Target
Exécutez CopyToBase

Option Explicit
Sub CopyToBase()
Dim FromSh As Worksheet, ToSh As Worksheet
Dim Cell    As Range
Dim FromName As String, Target As String, Address As String
Dim C       As Integer

    Target = ThisWorkbook.Path & "\" & "Base.xlsx"
    
    Set ToSh = OpenWs(Target, "Feuil1")
    If Not ToSh Is Nothing Then
        FromName = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)
        Set FromSh = ThisWorkbook.Worksheets("Feuil1")
        For C = 1 To 3
            Set Cell = FromSh.Columns(C).Find("*")
            If Not Cell Is Nothing Then
                Address = Cell.Address
                Do: Cell.Copy
                    ToSh.Cells(Cell.Row, Cell.Column).PasteSpecial xlPasteValues
                    ToSh.Cells(Cell.Row, "D") = FromName
                    Set Cell = FromSh.Columns(C).FindNext(Cell)
                Loop Until Address = Cell.Address
            End If
        Next
    End If
End Sub
Function OpenWs(Classeur As String, Feuille As String) As Worksheet
    On Error Resume Next
    Set OpenWs = Workbooks(Classeur).Worksheets(Feuille)
    If Err Then Set OpenWs = Workbooks.Open(Classeur).Worksheets(Feuille)
End Function

 

[SAMESS]

Bonjour,
Code à mettre dans un module de FF.xlsx
Vérifiez Target
Exécutez CopyToBase

Option Explicit
Sub CopyToBase()
Dim FromSh As Worksheet, ToSh As Worksheet
Dim Cell    As Range
Dim FromName As String, Target As String, Address As String
Dim C       As Integer

    Target = ThisWorkbook.Path & "\" & "Base.xlsx"
   
    Set ToSh = OpenWs(Target, "Feuil1")
    If Not ToSh Is Nothing Then
        FromName = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)
        Set FromSh = ThisWorkbook.Worksheets("Feuil1")
        For C = 1 To 3
            Set Cell = FromSh.Columns(C).Find("*")
            If Not Cell Is Nothing Then
                Address = Cell.Address
                Do: Cell.Copy
                    ToSh.Cells(Cell.Row, Cell.Column).PasteSpecial xlPasteValues
                    ToSh.Cells(Cell.Row, "D") = FromName
                    Set Cell = FromSh.Columns(C).FindNext(Cell)
                Loop Until Address = Cell.Address
            End If
        Next
    End If
End Sub
Function OpenWs(Classeur As String, Feuille As String) As Worksheet
    On Error Resume Next
    Set OpenWs = Workbooks(Classeur).Worksheets(Feuille)
    If Err Then Set OpenWs = Workbooks.Open(Classeur).Worksheets(Feuille)
End Function

Merci fanch55,
si j'ai changé les colonnes en principe le code sera changé non ?

 

[fanch55]

Merci fanch55,
si j'ai changé les colonnes en principe le code sera changé non ?

A adapter éventuellement :

For C = 1 To 3 ==> colonne 1 à 3 ( A,B,C )

ToSh.Cells(Cell.Row, "D") = FromName ==> colonne 4 ( D )