Maccro - copier sélection dans 2ème fichier par onglets

[Marie2601]

Bonjour,
Je souhaiterai créer une maccro qui permet de copier des lignes dans des onglets d'un autre fichier :
Fichier 1 - Dans la 1ère colonne, j'ai les éléments suivants (ligne 51, ligne 52, ligne 68, ligne 70...).
La maccro devra rechercher le lot des 50, 60, 70 puis venir les copier dans un fichier 2 par onglets (titre des onglets "lignes 51 à 58", "lignes 61 à 68"...).
Note : la maccro devra identifier que parfois la ligne n'est pas présente dans le fichier 1.

Pourriez-vous me donner des indications pour faire cette maccro ?
Merci bonne journée.
Marie.

 

[david84]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Bonjour,

Pourriez-vous me donner des indications pour faire cette maccro ?

Lance l'enregistreur de macro et effectue la procédure que tu as décrite : tu récupéreras ainsi la structure du code qu'il te faudra ensuite modifier pour le rendre plus efficace.

Note : la maccro devra identifier que parfois la ligne n'est pas présente dans le fichier 1.

Bizarre...si la ligne n'est pas présente dans le fichier 1, elle ne peut donc être copiée...j'ai l'impression que tu ne nous dis pas tout.
A+

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Bonjour Marie2601, bienvenue sur XLD,

Il serait souhaitable que vous déposiez vos fichiers sur le fil.

Mais avec ce que j'ai compris voyez les deux fichiers joints.

La macro dans Fichier 1 :

Sub Transfert()
Dim plage As Range, Wb As Workbook, w As Worksheet
Dim s, i1&, i2&, i&, cel As Range
On Error Resume Next
'nom de feuille à adapter
Set plage = ThisWorkbook.Sheets("Feuil1").[A:A] _
  .SpecialCells(xlCellTypeConstants, 2)
If Err Then Exit Sub 'rien à transférer
Set Wb = Workbooks("Fichier 2") 'nom du fichier à adapter
If Err Then MsgBox "Ouvrez 'Fichier 2'...", 48: Exit Sub
For Each w In Wb.Worksheets
  s = Split(w.Name)
  i1 = 0: i1 = Val(s(1))
  i2 = 0: i2 = Val(s(3))
  If i1 * i2 Then
    For i = i1 To i2
      For Each cel In plage
        If LCase(cel) = "ligne " & i Then _
          cel.EntireRow.Copy w.[A65536].End(xlUp)(2)
      Next
    Next
  End If
Next
End Sub

Edit : bonjour David, levés en même temps ce matin

A+

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Re,

Dans Fichier 2 il vaut mieux à chaque transfert :

- tout effacer

- coller la ligne des titres

- ajuster la largeur des colonnes.

Fichiers joints.

A+

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Re,

Cette version devrait être plus rapide :

Sub Transfert()
Dim plage As Range, Wb As Workbook, tablo&(), ub&
Dim i&, s, cel As Range, n&
On Error Resume Next
'nom de feuille à adapter
Set plage = ThisWorkbook.Sheets("Feuil1").[A:A] _
  .SpecialCells(xlCellTypeConstants, 2)
If Err Then Exit Sub 'rien à transférer
Set Wb = Workbooks("Fichier 2") 'nom du fichier à adapter
If Err Then MsgBox "Ouvrez 'Fichier 2'...", 48: Exit Sub
ReDim tablo(1 To Wb.Worksheets.Count, 1 To 2)
ub = UBound(tablo)
For i = 1 To ub
  Wb.Worksheets(i).Cells.Clear 'RAZ
  plage.Parent.[1:1].Copy Wb.Worksheets(i).[A1] 'titres
  s = Split(Wb.Worksheets(i).Name)
  tablo(i, 1) = Val(s(1)): tablo(i, 2) = Val(s(3))
Next
For Each cel In plage
  If LCase(cel) Like "ligne #*" Then
    n = Val(Mid(cel, 7))
    For i = 1 To ub
      If n >= tablo(i, 1) And n <= tablo(i, 2) Then
        cel.EntireRow.Copy Wb.Worksheets(i).[A65536].End(xlUp)(2)
        Wb.Worksheets(i).Columns.AutoFit 'largeur des colonnes
        Exit For
      End If
    Next
  End If
Next
End Sub

Noter l'utilisation d'un tableau pour les bornes de chaque feuille de Fichier 2.

A+

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Bonjour,

La macro sera encore plus rapide si, pour chaque ligne, on copie uniquement les valeurs :

Set plage = Intersect(cel.EntireRow, cel.Parent.UsedRange)
Wb.Worksheets(i).[A65536].End(xlUp)(2).Resize(, plage.Count) = plage.Value

Et cela peut être indispensable s'il y a des formules.

Fichier (2).

Où est Marie ? Elle a quitté le supermarché sans payer

A+

 

[Marie2601]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Bonjour et merci pour vos réponses (je profiterai du week-end pour faire les premiers tests).
Je vous transmets les fichier. Afin d'être plus explicite..
Merci et bonne journéé !

 

[Marie2601]

Re : Maccro - copier sélection dans 2ème fichier par onglets

second fichier

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Bonjour Marie2601,

Heureux de vous voir et merci pour vos fichiers.

J'ai adapté la macro du post #6 aux fichiers ci-joints.

Nota 1 : pas génial les espaces devant tous les "Ligne" dans le 1er fichier.

J'ai dû ajouter Trim sur ces lignes de code :

If LCase(Trim(cel)) Like "ligne #*" Then
  n = Val(Mid(Trim(cel), 7))

Nota 2 : j'ai modifié les noms des feuilles du 2ème fichier (pour un repérage facile des nombres).

A+

 

[job75]

Re : Maccro - copier sélection dans 2ème fichier par onglets

Re,

Pardon, dans le 2ème fichier la feuille "Bilan" était effacée.

Voici la bonne macro :

Sub Transfert()
Dim plage As Range, Wb As Workbook, tablo&(), ub&
Dim i&, s, cel As Range, n&
On Error Resume Next
'nom de feuille à adapter
Set plage = ThisWorkbook.Sheets("Copier ici la liste brute SAD ").[A:A] _
  .SpecialCells(xlCellTypeConstants, 2)
If Err Then Exit Sub 'rien à transférer
Set Wb = Workbooks("AAAAMMJJ Liste missions fichier 2") 'nom du fichier à adapter
If Err Then MsgBox "Ouvrez 'AAAAMMJJ Liste missions fichier 2'...", 48: Exit Sub
ReDim tablo(1 To Wb.Worksheets.Count, 1 To 2)
ub = UBound(tablo)
For i = 1 To ub
  s = Split(Wb.Worksheets(i).Name)
  On Error Resume Next
  tablo(i, 1) = Val(s(1)): tablo(i, 2) = Val(s(3))
  If Err = 0 Then
    Wb.Worksheets(i).Cells.ClearContents 'RAZ
    plage.Parent.[1:1].Copy Wb.Worksheets(i).[A1] 'titres
  End If
Next
For Each cel In plage
  If LCase(Trim(cel)) Like "ligne #*" Then
    n = Val(Mid(Trim(cel), 7))
    For i = 1 To ub
      If n >= tablo(i, 1) And n <= tablo(i, 2) Then
        Set plage = Intersect(cel.EntireRow, cel.Parent.UsedRange)
        Wb.Worksheets(i).[A65536].End(xlUp)(2).Resize(, plage.Count) = plage.Value
        Wb.Worksheets(i).Columns.AutoFit 'largeur des colonnes
        Exit For
      End If
    Next
  End If
Next
End Sub

Voir fichier (2) joint.

Edit : j'ai aussi modifié les formules des feuilles "Bilan".

A+