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

SAMESS

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

Pièces jointes

  • FF.xlsx
    12.3 KB · Affichages: 9
  • BAse.xlsx
    11 KB · Affichages: 7

fanch55

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

VB:
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

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

VB:
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 ?
 

Discussions similaires

Statistiques des forums

Discussions
312 816
Messages
2 092 360
Membres
105 378
dernier inscrit
y07