1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

XL 2010 Copie de données vers différents onglets à créer

Discussion dans 'Forum Excel' démarrée par citizenbaban, 27 Décembre 2018.

  1. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    Bonjour le forum,

    J'ai un petit problème avec un code VBA et je n'ai pas trouvé mon bonheur sur le forum :(

    Voici le topo : un onglet base de données (BdD dans le fichier joint) pour lequel j'aimerai que chaque ligne qui contiennent 2017 dans la colonne A soit copiée dans l'onglet "2017", idem pour 2018, etc.
    Cette partie là fonctionne, quoi que mon code peut sûrement être optimisé / épuré car j'ai en fait une macro par "année".
    L'idée c'est que l'on arrive en 2019 bientôt, puis 2020, etc. Les onglets "2019", "2020", seront créés par macro à partir d'une trame (celle là marche aussi) mais j'aimerai ne pas avoir à réadapter la macro "copie de données" à chaque nouvelle année.
    J'aimerai que le code réponde à ceci : si valeur en Ax de l'onglet BdD, alors copier la ligne dans l'onglet dont le nom est égal à cette valeur Ax. Et ce pour toutes les lignes :)
    Je pense cerner un peu l'idée mais je sèche sur sa transposition en VBA :(

    Bonne fêtes à tous.

    Citizen
     

    Pièces jointes:

  2. Chargement...

    Discussions similaires - Copie données vers Forum Date
    XL 2010 Copie données de textbox vers plusieurs feuilles Forum Excel 17 Décembre 2018
    XL 2007 Copier les données d'une feuille vers une autre Forum Excel 26 Juillet 2018
    XL 2016 [VBA] Copier données d'une feuille vers une autre feuille en fonction d'une valeur "critère" Forum Excel 17 Avril 2018
    XL 2007 Copier données d'une ligne Excel vers un formulaire Forum Excel 22 Mars 2018
    XL 2010 copier les données d'un fichier avec condition vers un fichier Forum Excel 2 Février 2018

  3. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    J'ai mouliné ce bout de code mais il tourne dans le vide

    Code (Text):
    Sub Copier_Lignes_Global()

    Application.ScreenUpdating = True

    Dim C, I, Compteur As Integer
    Dim sBdD As Worksheet
    Set sBdD = Worksheets("BdD")
    Dim derLig As Long
    derLig = sBdD.Cells(Rows.Count, 1).End(xlUp).Row
     
        For Compteur = 2 To ThisWorkbook.Sheets.Count
           
            sBdD.Activate
            C = 4
            For I = 3 To derLig
                If sBdD.Cells(I, 1).Text = ActiveSheet.Name Then
                sBdD.Range(Cells(I, 2), Cells(I, 20)).Copy
                ActiveSheet.Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
       
                C = C + 1
                End If
            Next I
         
            Compteur = Compteur + 1
        Next


    Application.CutCopyMode = False
    Application.ScreenUpdating = True


    End Sub
     
  4. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    Il y a du mieux...ce code-ci marche pour un de mes 3 onglets (mais pas pour les autres et je ne sais pas pourquoi...)

    Code (Text):

    Sub Copier_Lignes_Global()

    Application.ScreenUpdating = True

    Dim C, I, Compteur, Total_onglet As Integer
    Total_onglet = ThisWorkbook.Sheets.Count
    Dim sBdD As Worksheet
    Set sBdD = Worksheets("BdD")
    Dim derLig As Long
    derLig = sBdD.Cells(Rows.Count, 1).End(xlUp).Row
     
        For Compteur = 2 To Total_onglet
           
            sBdD.Activate
            C = 4
            For I = 3 To derLig
                If sBdD.Cells(I, 1).Text = ThisWorkbook.Sheets(Compteur).Name Then
                sBdD.Range(Cells(I, 2), Cells(I, 20)).Copy
                ThisWorkbook.Sheets(Compteur).Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
       
                C = C + 1
                End If
            Next I
         
            Compteur = Compteur + 1
        Next


    Application.CutCopyMode = False
    Application.ScreenUpdating = True


    End Sub
     
  5. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    Bon il y a vraiment quelque chose qui m'échappe, si quelqu'un veut bien me dire pourquoi ma macro ne se déroule pas sur les onglets 3, 4 et 5 je suis preneur.
    J'abandonne pour aujourd'hui.

    Merci

    Citizen


    Edit : en fait pour être précis, la macro ne se déroule qu'un onglet sur 2, qu'il soit "pair" ou "impair" dans son nom objet (feuil1, feuil2, etc)

    Edit2 : Ok je suis un boulet, je viens de voir mon erreur.....un next qui trainait en fin de code, résidu d'un mauvais copier/coller...
     

    Pièces jointes:

    • Citizen.xls
      Taille du fichier:
      94.5 Ko
      Affichages:
      14
    Dernière édition: 28 Décembre 2018
  6. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    Bonne année à tous,

    Est-ce que quelqu'un a pu regarder mon code afin de savoir si il pouvait être épuré?

    Code (Text):
    Sub Copier_Ligne_Global_Plus_Nettoyage()

    Application.ScreenUpdating = False

    Dim C, I, Compteur, N, V, Total_onglet As Integer
    Total_onglet = ThisWorkbook.Sheets.Count
    Dim sArch As Worksheet
    Set sArch = Worksheets("Archives")
    Dim derLig As Long
    derLig = sArch.Cells(Rows.Count, 1).End(xlUp).Row
    Dim lastLig As Long
    Dim CelVide As Range



            For V = 4 To Total_onglet
            Sheets(V).Activate
            lastLig = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            If lastLig > 3 Then
            Range(Cells(4, 1), Cells(lastLig, 19)).Select
            Selection.EntireRow.Delete
            Else
            End If
            Next V



            sArch.Activate
            Cells.EntireColumn.Hidden = False



            For Compteur = 4 To Total_onglet
           
            sArch.Activate
            C = 4
            For I = 3 To derLig
            If sArch.Cells(I, 1).Text = ThisWorkbook.Sheets(Compteur).Name Then
            sArch.Range(Cells(I, 2), Cells(I, 20)).Copy
            ThisWorkbook.Sheets(Compteur).Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

            C = C + 1
            End If
            Next I
         
            Next Compteur




            For N = 4 To Total_onglet
            Sheets(N).Activate
            lastLig = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row


            Range(Cells(4, 1), Cells(lastLig, 19)).Select
            Selection.Borders.Value = 1


            For Each CelVide In Range(Cells(4, 1), Cells(lastLig, 19))
            If CelVide = "" Then CelVide.Interior.Color = RGB(206, 206, 206)
            Next CelVide
           
            Cells(lastLig + 1, 1).Activate
            Cells(lastLig + 1, 1).Show
            Next N


            sArch.Activate
            Range("A:A").EntireColumn.Hidden = True
            Cells(lastLig, 2).Activate
            Cells(lastLig, 2).Show
           
           
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

    End Sub
    J'ai également une petite question car il me fait quelque chose d'un peu étrange, bien que purement esthétique : La fin du code sert pour la mise en forme des lignes, notamment pour griser les cellules vides. Comme j'ai mis un range plutôt qu'une boucle, si la macro tourne sans valeur à copier, elle va me griser la ligne 4. Ca en soit, ce n'est pas grave. Mais si je la relance avec cette fois une valeur à copier, elle va me copier cette valeur ligne 4, très bien, mais la ligne va rester grise, alors que le début de code est sensé supprimer les lignes à partir de la ligne 4. Pourquoi est-ce que je ne me retrouve pas avec une ligne blanche avant la copie des données et que j'ai une ligne grise ?

    Merci

    Citizen
     
  7. cp4

    cp4 XLDnaute Impliqué

    Inscrit depuis le :
    7 Novembre 2015
    Messages :
    517
    "J'aime" reçus :
    32
    Utilise:
    Excel 2010 (PC)
    Bonjour,

    Si j'ai bien compris, macro à tester
    Code (Visual Basic):
    Option Explicit

    Sub Dispatcher()
      Dim ShBd As Worksheet, ShTr As Worksheet, d As Object, i As Integer, Sh As Worksheet, dl As Integer, clé, c As Range
      Set ShBd = ThisWorkbook.Worksheets("BdD")
      Set ShTr = ThisWorkbook.Worksheets("Trame")
      Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
      For Each Sh In Worksheets
      If Sh.Name <> ShBd.Name And Sh.Name <> ShTr.Name Then
      Application.DisplayAlerts = False
      Sh.Delete
      Application.DisplayAlerts = True
      End If
      Next

      With ShBd
      dl = .Range("A" & Rows.Count).End(xlUp).Row
      For i = 3 To dl
      If Not d.exists(.Range("A" & i).Value) Then
      d(.Range("A" & i).Value) = ""
      End If
      Next i
      End With

      ShTr.Visible = xlSheetVisible

      For Each clé In d.keys
      Sheets.Add(after:=Sheets(Sheets.Count)).Name = clé
      ShTr.Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
      ActiveSheet.Range("A1") = clé
      For Each c In ShBd.Range("A3:A" & ShBd.Range("A" & Rows.Count).End(xlUp).Row)
      If c.Value = clé Then
      i = c.Row
      dl = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
      ShBd.Range(ShBd.Cells(i, 2), ShBd.Cells(i, 20)).Copy Destination:=ActiveSheet.Cells(dl, 1)
      End If
      Next
      Next
      ShTr.Visible = xlSheetHidden
      ShBd.Activate
      Application.ScreenUpdating = True
    End Sub
     
     
  8. citizenbaban

    citizenbaban XLDnaute Nouveau

    Inscrit depuis le :
    7 Avril 2010
    Messages :
    40
    "J'aime" reçus :
    1
    Habite à:
    Leyment
    Utilise:
    Excel 2010 (PC)
    Bonjour Cp4,

    J'ai une erreur d'exécution 1004 sur la ligne 29 : Sheets.Add(after:=Sheets(Sheets.Count)).Name = clé

    Est-ce que tu peux m'expliquer un peu ton code pour être sûr que je ne sois pas à côté de la plaque ? surtout pour ces points :
    Code (Text):
    Set d = CreateObject("Scripting.Dictionary")
    Code (Text):
    For Each clé In d.keys
    Je te remercie,

    Bonne journée.

    Citizen
     

Partager cette page