copier coller venant d un fichier a un autre

[cg1980]

j aimerais copier les donnes de structure a portfolio de la manière suivante.

tout d'abord on prend toutes les celulles de la colonne A qui contiennent "Corp" du fichier structure et on les copie dans la colonne B de portfolio.

On copie également la colonne AD de structure dans C de portfolio et AT dans D des memes fichiers.

Ensuite une dernière chose.

Dans la colonne E de Portfolio, j'aimerais indiquée S qui signifie que les donnes viennenet du fichier structure car je repeterais la meme operation venant d'autres fichiers.

merci d'avance

 

[Robert]

Re : copier coller venant d un fichier a un autre

Bonjour cg, bonjour le forum,

Si les deux classeurs sont ouverts, essaie comme ça :

Sub Macro1()
Dim cs As Workbook 'déclare la variable cs (Classeur Source)
Dim cc As Workbook 'déclare la variable cc (Classeur Cible)
Dim os As Object 'déclare la variable os (Onglet Source)
Dim oc As Object 'déclare la variable oc (Onglet Cible)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)


Set cs = ThisWorkbook 'définitle classeur source cs
Set cc = Workbooks("Portfolio test.xlsm") 'définit la classeur cible cc (à adapter à ton vrai fichier)
Set os = cs.Sheets("Sheet1") 'définit l'onglet source os
Set oc = cc.Sheets("Sheet1") 'définit l'onglet cible oc
dl = os.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet source
Set pl = os.Range("A2:A" & dl) 'définit la plage pl
For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
    If Right(cel.Value, 4) = "Corp" Then 'condition : si les 4 derniers caractères de la cellule cel sont "Corp"
        Set dest = IIf(oc.Range("A3").Value = "", oc.Range("A3"), oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)) 'définit la cellule de destination dest
        dest.Value = cel.Value 'récupère la valeur de la cellule cel dans dest
        dest.Offset(0, 2) = os.Cells(cel.Row, 30).Value 'récupère la valeur de la cellule de la colonne AD et la colle dans la colonne C
        dest.Offset(0, 3) = os.Cells(cel.Row, 46).Value 'récupère la valeur de la cellule de la colonne AT et la colle dans la colonne D
        dest.Offset(0, 4).Value = "S" 'place "S" dans la colonne E
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle
End Sub

Vérifie bien le nom du classeur cible. À adapter éventuellement...

 

[job75]

Re : copier coller venant d un fichier a un autre

Bonjour cg1980, salut Robert,

Exécuter cette macro qui utilise le filtre automatique :

Sub Transfert()
On Error Resume Next
With Workbooks("Structure.xlsm").Sheets(1)
  Workbooks("Portfolio test.xlsm").Sheets(1).Activate
  If Err Then MsgBox "Les deux fichiers doivent être ouverts": Exit Sub
  .Columns("C:AC").Hidden = True 'au cas où...
  .Rows(1).Insert '1ère ligne du filtre
  .[A:A].AutoFilter 1, "*Corp"
  .AutoFilter.Range.EntireRow.Offset(1).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.[A1]
  .AutoFilterMode = False
  .Rows(1).Delete
End With
With ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp)
  .Parent.[E1].Resize(.Row) = "S"
  .Parent.Columns.AutoFit 'ajustement de la largeur
  .Parent.Rows(.Row + 1 & ":" & .Parent.Rows.Count).Clear
End With
End Sub

A+

 

[job75]

Re : copier coller venant d un fichier a un autre

Re,

Ah oui la macro précédente ne fait pas exactement ce que vous avez demandé, alors utilisez :

Sub Transfert()
On Error Resume Next
With Workbooks("Structure.xlsm").Sheets(1)
  Workbooks("Portfolio test.xlsm").Sheets(1).Activate
  If Err Then MsgBox "Les deux fichiers doivent être ouverts": Exit Sub
  .[B:AC,AE:AS].EntireColumn.Hidden = True 'masque aussi la colonne B
  .[A:AT].AutoFilter 1, "*Corp"
  .AutoFilter.Range.Offset(-Not .[A1] Like "*Corp") _
    .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.[B1]
  .AutoFilterMode = False
  .Columns("B").Hidden = False 'affiche la colonne B
End With
With ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp)
  .Parent.[E1].Resize(.Row) = "S"
  .Parent.Columns.AutoFit 'ajustement de la largeur
  .Parent.Rows(.Row + 1 & ":" & .Parent.Rows.Count).Clear
End With
End Sub

Edit : j'évite l'insertion de la 1ère ligne grâce à .Offset(-Not .[A1] Like "*Corp")

A+

 

[cg1980]

Re : copier coller venant d un fichier a un autre

merci. j ai essaye d adapter mais en fait je dois faire la meme operation d autre fichier xls. j aurais besoin que les donnes s empilent alors que comme ca effacera les donnees. je voulais aligner les codes par fichier mais en faisant cela, jefface les donnees.
merci envoer

 

[job75]

Re : copier coller venant d un fichier a un autre

Re,

Si vous voulez coller les données après la dernière ligne occupée :

Sub Transfert()
Dim cel As Range
On Error Resume Next
With Workbooks("Structure.xlsm").Sheets(1)
  Workbooks("Portfolio test.xlsm").Sheets(1).Activate
  If Err Then MsgBox "Les deux fichiers doivent être ouverts": Exit Sub
  .[B:AC,AE:AS].EntireColumn.Hidden = True 'masque aussi la colonne B
  .[A:AT].AutoFilter 1, "*Corp"
  Set cel = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp)(2)
  If cel.Row = 2 And cel(0) = "" Then Set cel = ActiveSheet.[B1]
  .AutoFilter.Range.Offset(-Not .[A1] Like "*Corp") _
    .SpecialCells(xlCellTypeVisible).Copy cel
  .AutoFilterMode = False
  .Columns("B").Hidden = False 'affiche la colonne B
End With
With ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp)
  cel(1, 4).Resize(.Row - cel.Row + 1) = "S"
  .Parent.Columns.AutoFit 'ajustement de la largeur
End With
End Sub

Mais attention si vous exécutez plusieurs fois la macro avec le même fichier source...

A+

 

[job75]

Re : copier coller venant d un fichier a un autre

Annulé, je me suis trompé de fil, voyez le post précédent...