recopier des données d'un classeur vers des onglets spécifiques d'un autre

superbog

XLDnaute Occasionnel
Bonsoir et tous mes voeux à tous, et merci de votre implication.

Voilà mon souci.

Je souhaite relier des classeurs excel entre eux de la façon suivante:

J'ai un classeur tps avec 5 colonnes id date numéro nom libellé durée et un autre classeur dos avec un onglet par numéro et dans chaque onglet

je voudrais à l'aide d'une macro que chaque fois qu'un numéro précis apparait dans la colonne numéro de ce classeur, alors les cellules date, diligences, précisions et durée de la même ligne se recopient dans l'onglet portant ce même numéro dans le classeur, l'un en dessous l'autre à compter de la 10 ème ligne et que la ligne traitée dans le classeur d'origine soit surlignée en gris.



Ci joint les deux classeurs


Merci d'avance de votre aide
 

Pièces jointes

  • tps.xlsx
    8.8 KB · Affichages: 62
  • dos.xlsx
    13.1 KB · Affichages: 67
  • tps.xlsx
    8.8 KB · Affichages: 65
  • dos.xlsx
    13.1 KB · Affichages: 70
  • tps.xlsx
    8.8 KB · Affichages: 65
  • dos.xlsx
    13.1 KB · Affichages: 72

Robert

XLDnaute Barbatruc
Repose en paix
Re : recopier des données d'un classeur vers des onglets spécifiques d'un autre

Bonsoir Superbog, bonsoir le forum,

En pièce jointe le fichier tps.xlsm contenant un bouton et le code ci-dessous :
Code:
Sub Macro1()
Dim dl As Long '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 cc As Workbook 'déclare la variable cc (Classeur Cible)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
    dl = .Cells(Application.Rows.Count, 3).End(xlUp).Row 'définit la dernière ligne dl
    Set pl = .Range("C2:C" & dl) 'définit la plage pl
End With 'fin de la prise en compte de l'onglet "Feuil1"
Set cc = Workbooks("dos.xlsx") 'défini8t le classeur cible

For Each cel In pl 'boucle sur toutes les cellules éditées cel de la plage pl
    If cel.Interior.ColorIndex <> 48 Then 'si couleur de la cellule n'est pas gris 40%
        On Error Resume Next 'gestion des erreurs (passe à ligne suivant en cas d'erreur)
        'définit la cellule de destination dest (génère une erreur si l'onglet n'existe pas)
        Set dest = cc.Sheets(CStr(cel.Value)).Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
        If Err <> 0 Then 'condition : si une erreur a éteé générée
            MsgBox "L'onglet " & cel.Value & " n'exite pas dans le classeur dos.xlsx !" 'message
            Err.Clear 'supprime l'erreur
            GoTo suite 'va à l'étiquette "suite" (sans exporter de données)
        End If 'fin de la condition
        On Error GoTo 0 'annule la gestion des erreurs
        With Range(Cells(cel.Row, 1), Cells(cel.Row, 7)) 'prend en compte la ligne (colonnes A à G)
            .Copy dest 'copie la ligne te la colle dans dest
            .Interior.ColorIndex = 48 'colore la ligne de gris 0%
        End With 'fin de la prise en compte de la ligne
    End If 'fin de la condition

suite: 'étiquette
Next cel 'prochaine cellule cel de boucle
End Sub
Le fichier :

 

Pièces jointes

  • tps.xlsm
    21.9 KB · Affichages: 77
  • tps.xlsm
    21.9 KB · Affichages: 84
  • tps.xlsm
    21.9 KB · Affichages: 86

Staple1600

XLDnaute Barbatruc
Re : recopier des données d'un classeur vers des onglets spécifiques d'un autre

Bonsoir à tous


Une autre approche (test ok sur mon PC avec les deux fichiers ouverts)
Avant de lancer la macro (à copier dans tps), enregistrer tps (sinon le code VBA sera perdu)

NB: J'ai fait le test en ayant comme UsedRange que la tableau (soit la plage A1:G10)
(--> et j'ai supprimé le Commandbutton)

Code:
Sub test()
Dim Wks As Worksheet, a As Workbook
Dim HPB As HPageBreak, Lig&, i&, x&
Set a = Workbooks("dos.xls"): Set Wks = ActiveSheet: Lig = 2: i = 1
Application.ScreenUpdating = 0
Wks.[A1].CurrentRegion.Subtotal GroupBy:=3, Function:=xlSum, _
        TotalList:=Array(7), Replace:=False, _
        PageBreaks:=True, SummaryBelowData:=False
Wks.Range("A16").Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
For Each HPB In Wks.HPageBreaks
With Wks
    x = HPB.Location.Row
    .Range(.Cells(Lig, "A"), _
    .Cells(x - 1, "B")).SpecialCells(2).Copy a.Sheets(i).[A21]
    .Range(.Cells(Lig, "E"), _
    .Cells(x - 1, "E")).SpecialCells(2).Resize(, 3).Copy a.Sheets(i).[C21]
End With
Lig = HPB.Location.Row: i = i + 1
Next HPB
ThisWorkbook.Close False
End Sub
 

superbog

XLDnaute Occasionnel
Re : recopier des données d'un classeur vers des onglets spécifiques d'un autre

Merci Robert, ca marche mais cela recopie la totalité des cellules et non seulement les cellules concernées soit id/date/diligences/précisions/durée
comment faire?
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG